Released DG*5.3*646 SEQ #556 Extracted from mail message **KIDS**:DG*5.3*646^ **INSTALL NAME** DG*5.3*646 "BLD",5478,0) DG*5.3*646^REGISTRATION^0^3050124^y "BLD",5478,4,0) ^9.64PA^^ "BLD",5478,"KRN",0) ^9.67PA^8989.52^19 "BLD",5478,"KRN",.4,0) .4 "BLD",5478,"KRN",.401,0) .401 "BLD",5478,"KRN",.402,0) .402 "BLD",5478,"KRN",.403,0) .403 "BLD",5478,"KRN",.5,0) .5 "BLD",5478,"KRN",.84,0) .84 "BLD",5478,"KRN",3.6,0) 3.6 "BLD",5478,"KRN",3.8,0) 3.8 "BLD",5478,"KRN",9.2,0) 9.2 "BLD",5478,"KRN",9.8,0) 9.8 "BLD",5478,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",5478,"KRN",9.8,"NM",1,0) DGRPMS^^0^B35374783 "BLD",5478,"KRN",9.8,"NM","B","DGRPMS",1) "BLD",5478,"KRN",19,0) 19 "BLD",5478,"KRN",19.1,0) 19.1 "BLD",5478,"KRN",101,0) 101 "BLD",5478,"KRN",409.61,0) 409.61 "BLD",5478,"KRN",771,0) 771 "BLD",5478,"KRN",870,0) 870 "BLD",5478,"KRN",8989.51,0) 8989.51 "BLD",5478,"KRN",8989.52,0) 8989.52 "BLD",5478,"KRN",8994,0) 8994 "BLD",5478,"KRN","B",.4,.4) "BLD",5478,"KRN","B",.401,.401) "BLD",5478,"KRN","B",.402,.402) "BLD",5478,"KRN","B",.403,.403) "BLD",5478,"KRN","B",.5,.5) "BLD",5478,"KRN","B",.84,.84) "BLD",5478,"KRN","B",3.6,3.6) "BLD",5478,"KRN","B",3.8,3.8) "BLD",5478,"KRN","B",9.2,9.2) "BLD",5478,"KRN","B",9.8,9.8) "BLD",5478,"KRN","B",19,19) "BLD",5478,"KRN","B",19.1,19.1) "BLD",5478,"KRN","B",101,101) "BLD",5478,"KRN","B",409.61,409.61) "BLD",5478,"KRN","B",771,771) "BLD",5478,"KRN","B",870,870) "BLD",5478,"KRN","B",8989.51,8989.51) "BLD",5478,"KRN","B",8989.52,8989.52) "BLD",5478,"KRN","B",8994,8994) "BLD",5478,"QUES",0) ^9.62^^ "BLD",5478,"REQB",0) ^9.611^1^1 "BLD",5478,"REQB",1,0) DG*5.3*626^2 "BLD",5478,"REQB","B","DG*5.3*626",1) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 646^3050124 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 1 "RTN","DGRPMS") 0^1^B35374783 "RTN","DGRPMS",1,0) DGRPMS ;ALB/BRM,LBD - MILITARY SERVICE APIS ; 1/24/05 8:44am "RTN","DGRPMS",2,0) ;;5.3;Registration;**451,626,646**;Aug 13, 1993 "RTN","DGRPMS",3,0) ; "RTN","DGRPMS",4,0) VALCON(DFN,CNFLCT,CDATE,FRTO) ;is this a valid conflict input? "RTN","DGRPMS",5,0) ; "RTN","DGRPMS",6,0) ;INPUT: "RTN","DGRPMS",7,0) ; FRTO - 0=FRDT 1=TODT (defaults to FRDT if FRTO="") "RTN","DGRPMS",8,0) ; "RTN","DGRPMS",9,0) N RTN,X,Y,FRDT,TODT,CNFLCTV,IGNORE,COMPOW,MSG,DTCHK,CNFLCT2 "RTN","DGRPMS",10,0) Q:'$D(DFN) "0^INVALID PATIENT" "RTN","DGRPMS",11,0) Q:'$D(^DPT(DFN)) "0^INVALID PATIENT" "RTN","DGRPMS",12,0) Q:'$$VALID^DGRPDT(.CDATE) "0^INVALID DATE" "RTN","DGRPMS",13,0) S FRTO=+$G(FRTO) "RTN","DGRPMS",14,0) I 'FRTO S TODT=$$GETDT(DFN,.CNFLCT),FRDT=CDATE K DGFRDT "RTN","DGRPMS",15,0) E S FRDT=$$GETDT(DFN,.CNFLCT,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=CDATE K DGFRDT "RTN","DGRPMS",16,0) S DTCHK=$$DTUTIL^DGRPDT(CDATE,$$GETDT(DFN,.CNFLCT,'FRTO),1) "RTN","DGRPMS",17,0) I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) Q DTCHK "RTN","DGRPMS",18,0) I CNFLCT="COMB"!(CNFLCT="POW") D "RTN","DGRPMS",19,0) .S COMPOW=$S(CNFLCT="COMB":1,1:2) "RTN","DGRPMS",20,0) .S CNFLCT2=CNFLCT "RTN","DGRPMS",21,0) .S CNFLCT=$$COMPOW($S($G(DGCOMLOC):$P(DGCOMLOC,"^"),1:$$GETDT(DFN,CNFLCT,3))) "RTN","DGRPMS",22,0) S CNFLCTV="" "RTN","DGRPMS",23,0) I CNFLCT]"" S CNFLCTV=$$CNFLCTDT^DGRPDT(FRDT,$S(FRTO:TODT,1:""),.CNFLCT) "RTN","DGRPMS",24,0) I ('CNFLCTV) D MSG($P(CNFLCTV,"^",2),2,1) Q CNFLCTV ;dates are not within conflict "RTN","DGRPMS",25,0) ; "RTN","DGRPMS",26,0) S MSG=$S('$G(COMPOW):"Conflict",$G(COMPOW)=2:"POW",1:"Combat") "RTN","DGRPMS",27,0) I FRDT,TODT,'$$B4^DGRPDT(FRDT,TODT,0) D MSG((MSG_" From Date is not Before "_MSG_" To Date"),2,1) Q "0^"_MSG_" From Date is not Before "_MSG_" To Date" "RTN","DGRPMS",28,0) S IGNORE=$P($P($T(@(CNFLCT)),";;",2),"^",FRTO+1) "RTN","DGRPMS",29,0) S:$G(COMPOW) IGNORE=$P($P($T(@(CNFLCT2)),";;",2),"^",FRTO+1) "RTN","DGRPMS",30,0) I $G(COMPOW)=2 S RTN=$$OVRLPCHK^DGRPDT(DFN,FRDT,TODT,-1,IGNORE) "RTN","DGRPMS",31,0) E S RTN=$$COVRLP2^DGRPDT(DFN,FRDT,TODT,IGNORE) "RTN","DGRPMS",32,0) Q:RTN RTN "RTN","DGRPMS",33,0) D MSG($P(RTN,"^",2),2,1) "RTN","DGRPMS",34,0) Q RTN "RTN","DGRPMS",35,0) ; "RTN","DGRPMS",36,0) VALMSE(DFN,MDATE,FRTO,FLD) ;is this a valid Military Service Episode date? "RTN","DGRPMS",37,0) ; "RTN","DGRPMS",38,0) ;INPUT: "RTN","DGRPMS",39,0) ; FRTO - 0=FRDT 1=TODT (defaults to FRDT if FRTO="") "RTN","DGRPMS",40,0) ; FLD - MSE field being edited/added (MSL,MSNTL,MSNNTL) "RTN","DGRPMS",41,0) ; "RTN","DGRPMS",42,0) N RTN,X,Y,FRDT,TODT,IGNORE,DTCHK "RTN","DGRPMS",43,0) Q:'$D(DFN) "0^INVALID PATIENT" "RTN","DGRPMS",44,0) Q:'$D(^DPT(DFN)) "0^INVALID PATIENT" "RTN","DGRPMS",45,0) Q:'$$VALID^DGRPDT(.MDATE) "0^INVALID DATE" "RTN","DGRPMS",46,0) S FRTO=+$G(FRTO) "RTN","DGRPMS",47,0) I 'FRTO S FRDT=MDATE,TODT=$$GETDT(DFN,.FLD,FRTO) K DGFRDT "RTN","DGRPMS",48,0) E S FRDT=$$GETDT(DFN,.FLD,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=MDATE K DGFRDT "RTN","DGRPMS",49,0) S DTCHK=$$DTUTIL^DGRPDT(MDATE,$$GETDT(DFN,.FLD,'FRTO),1) "RTN","DGRPMS",50,0) I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) K DGCOMBR Q DTCHK "RTN","DGRPMS",51,0) I FRTO,FRDT,TODT,'$$B4^DGRPDT(.FRDT,.TODT,0) D MSG("Service Entry Date is not before Service Separation Date",2,1) K DGCOMBR Q "0^Service Entry Date is not before Service Separation Date" "RTN","DGRPMS",52,0) S IGNORE=$P($P($T(@(FLD)),";;",2),"^",FRTO+1) "RTN","DGRPMS",53,0) S RTN=$$OVRLPCHK^DGRPDT(.DFN,.FRDT,.TODT,1,.IGNORE) "RTN","DGRPMS",54,0) I $G(DGCOMBR)']"" S DGCOMBR=$$GETDT(DFN,.FLD,4) "RTN","DGRPMS",55,0) I RTN,FRTO,$$BRANCH(.DGCOMBR),('$$WWII(DFN,TODT,.FLD)) D MSG("Branch of Service Requires WWII Dates of Service",2,1) K DGCOMBR Q "0^BOS Requires WWII Dates" "RTN","DGRPMS",56,0) K DGCOMBR "RTN","DGRPMS",57,0) Q:RTN RTN "RTN","DGRPMS",58,0) D MSG($P(RTN,"^",2),2,1) "RTN","DGRPMS",59,0) Q RTN "RTN","DGRPMS",60,0) ; "RTN","DGRPMS",61,0) BRANCH(DGCOMBR) ;branches of service that require WWII service dates "RTN","DGRPMS",62,0) N BRANCH "RTN","DGRPMS",63,0) Q:'$G(DGCOMBR) 0 "RTN","DGRPMS",64,0) S BRANCH=$P(DGCOMBR,"^",2) "RTN","DGRPMS",65,0) Q:BRANCH="MERCHANT SEAMAN" 1 "RTN","DGRPMS",66,0) Q:BRANCH="F.COMMONWEALTH" 1 "RTN","DGRPMS",67,0) Q:BRANCH="F.GUERILLA" 1 "RTN","DGRPMS",68,0) Q:BRANCH="F.SCOUTS NEW" 1 "RTN","DGRPMS",69,0) Q:BRANCH="F.SCOUTS OLD" 1 "RTN","DGRPMS",70,0) Q 0 "RTN","DGRPMS",71,0) ; "RTN","DGRPMS",72,0) GETDT(DFN,CNFLCT,FRTO) ; get from date, to date, or location from patient file "RTN","DGRPMS",73,0) ; "RTN","DGRPMS",74,0) N CFLDS,CFLD,RTN1 "RTN","DGRPMS",75,0) Q:'$D(DFN) "" "RTN","DGRPMS",76,0) Q:'$D(^DPT(DFN)) "" "RTN","DGRPMS",77,0) Q:$G(CNFLCT)="" "" "RTN","DGRPMS",78,0) S:$G(FRTO)="" FRTO=0 "RTN","DGRPMS",79,0) S CFLDS=$P($T(@(CNFLCT)),";;",2) Q:CFLDS']"" "" "RTN","DGRPMS",80,0) S CFLD=$S('FRTO:$P(CFLDS,"^",2),FRTO=1:$P(CFLDS,"^"),1:$P(CFLDS,"^",3)) "RTN","DGRPMS",81,0) Q:'CFLD "" "RTN","DGRPMS",82,0) S RTN1=$$GET1^DIQ(2,DFN_",",CFLD,"I") "RTN","DGRPMS",83,0) I FRTO=4 S RTN1=RTN1_"^"_$$EXTERNAL^DILFD(2,CFLD,"",RTN1) "RTN","DGRPMS",84,0) Q RTN1 "RTN","DGRPMS",85,0) ; "RTN","DGRPMS",86,0) WWII(DFN,TODT,FLD) ; was this patient in WWII? "RTN","DGRPMS",87,0) ; this API assumes the WWII period to be from 12/07/41-12/31/46 "RTN","DGRPMS",88,0) ; "RTN","DGRPMS",89,0) N OK,NODE,DATA,WWIIS,WWIIE,PATDT,PATE,PATS "RTN","DGRPMS",90,0) Q:'$G(DFN) "-1^UNKNOWN" "RTN","DGRPMS",91,0) S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298" "RTN","DGRPMS",92,0) S WWIIS=2411207,WWIIE=2461231 "RTN","DGRPMS",93,0) D GETDAT^DGRPDT(DFN,.NODE,.DATA) "RTN","DGRPMS",94,0) S PATDT=$G(FLD) Q:PATDT']"" 0 "RTN","DGRPMS",95,0) S PATS=$P($G(DATA(PATDT)),"^"),PATE=$P($G(DATA(PATDT)),"^",2) "RTN","DGRPMS",96,0) S:'$G(TODT) TODT=PATE "RTN","DGRPMS",97,0) S OK=0 "RTN","DGRPMS",98,0) S OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,PATS) "RTN","DGRPMS",99,0) S:'OK OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,TODT) "RTN","DGRPMS",100,0) S:'OK OK=$$RWITHIN^DGRPDT(PATS,TODT,WWIIS,WWIIE) "RTN","DGRPMS",101,0) Q $G(OK) "RTN","DGRPMS",102,0) DELMSE(DFN,TYPE) ; delete MSE from patient "RTN","DGRPMS",103,0) ; "RTN","DGRPMS",104,0) ; Input: DFN - Internal entry number for the Patient File (#2) "RTN","DGRPMS",105,0) ; TYPE - 1=Last MSE 2=Next to Last MSE 3=Next to Next to Last "RTN","DGRPMS",106,0) ; "RTN","DGRPMS",107,0) Q:'$G(TYPE) "RTN","DGRPMS",108,0) Q:(('$G(DFN))!'$D(^DPT(DFN))) "RTN","DGRPMS",109,0) N IENS,FDA,X,X1,X2,Y,ZZ,ROOT "RTN","DGRPMS",110,0) S IENS=DFN_",",ROOT="FDA(2,IENS)",X="" "RTN","DGRPMS",111,0) I TYPE=1 F ZZ=.324,.326,.327,.328 S @ROOT@(ZZ)=X "RTN","DGRPMS",112,0) I TYPE=2 F ZZ=.329,.3292,.3293,.3294 S @ROOT@(ZZ)=X "RTN","DGRPMS",113,0) I TYPE=3 F ZZ=.3295,.3297,.3298,.3299 S @ROOT@(ZZ)=X "RTN","DGRPMS",114,0) D FILE^DIE("K","FDA","ERR") "RTN","DGRPMS",115,0) Q "RTN","DGRPMS",116,0) ; "RTN","DGRPMS",117,0) COMPOW(VAL) ;convert POW and Combat Location fields "RTN","DGRPMS",118,0) ; "RTN","DGRPMS",119,0) N ABRV "RTN","DGRPMS",120,0) Q:'$G(VAL) "" "RTN","DGRPMS",121,0) S ABRV=$$GET1^DIQ(22,VAL_",",1,"I") "RTN","DGRPMS",122,0) Q:ABRV="WWI" "WWI" "RTN","DGRPMS",123,0) Q:ABRV="WWII-EUROPE" "WWIIE" "RTN","DGRPMS",124,0) Q:ABRV="WWII-PACIFIC" "WWIIP" "RTN","DGRPMS",125,0) Q:ABRV="KOREAN" "KOR" "RTN","DGRPMS",126,0) Q:ABRV="VIETNAM" "VIET" "RTN","DGRPMS",127,0) Q:ABRV="OTHER" "OTHER" "RTN","DGRPMS",128,0) Q:ABRV="PERSIAN GULF" "GULF" "RTN","DGRPMS",129,0) Q:ABRV="YUGOSLAVIA" "YUG" "RTN","DGRPMS",130,0) Q:ABRV="SOMALIA" "SOM" "RTN","DGRPMS",131,0) Q "" "RTN","DGRPMS",132,0) ; "RTN","DGRPMS",133,0) FV(X) ;Is this a Filipino Vet branch of service? "RTN","DGRPMS",134,0) ;Added for HVE II (DG*5.3*451) "RTN","DGRPMS",135,0) ;INPUT: X = IEN Branch of Service file #23 "RTN","DGRPMS",136,0) ;OUTPUT: 1 = Filipino Vet BOS (F.COMMONWEALTH, F.GUERILLA, F.SCOUTS NEW) "RTN","DGRPMS",137,0) ; 2 = Filipino Vet BOS (F.SCOUTS OLD) "RTN","DGRPMS",138,0) ; 0 = Not Filipino Vet BOS "RTN","DGRPMS",139,0) N FV "RTN","DGRPMS",140,0) I '$G(X) Q 0 "RTN","DGRPMS",141,0) S FV=$P($G(^DIC(23,X,0)),U,1) "RTN","DGRPMS",142,0) Q $S(FV="F.SCOUTS OLD":2,$E(FV,1,2)="F.":1,1:0) "RTN","DGRPMS",143,0) ; "RTN","DGRPMS",144,0) FVP ;MUMPS cross-reference "AFV1" on Service Branch [Last] (#.325), "AFV2" "RTN","DGRPMS",145,0) ;on Service Branch [NTL] (#.3291), and "AFV3" on Service Branch [NNTL] "RTN","DGRPMS",146,0) ;(#.3296) in the Patient file #2. If the Service Branch fields do not "RTN","DGRPMS",147,0) ;contain a Filipino Veteran branch of service, the Filipino Vet Proof "RTN","DGRPMS",148,0) ;field (#.3214) will be deleted. "RTN","DGRPMS",149,0) Q:'$G(DA) "RTN","DGRPMS",150,0) N BOS,MS,FV,IENS,FDA "RTN","DGRPMS",151,0) S MS=$G(^DPT(DA,.32)) "RTN","DGRPMS",152,0) F BOS=5,10,15 S FV=$$FV($P(MS,U,BOS)) Q:FV=1 "RTN","DGRPMS",153,0) I FV=1 Q ;Filipino Vet BOS found, quit "RTN","DGRPMS",154,0) ;Delete Filipino Vet Proof "RTN","DGRPMS",155,0) S IENS=DA_",",FDA(2,IENS,.3214)="@" "RTN","DGRPMS",156,0) D FILE^DIE("","FDA") "RTN","DGRPMS",157,0) Q "RTN","DGRPMS",158,0) ; "RTN","DGRPMS",159,0) MSG(MSGTXT,LF1,LF2) ; This api will format the output text in order to utilize "RTN","DGRPMS",160,0) ; the EN^DDIOL utility. "RTN","DGRPMS",161,0) ;INPUT: MSGTXT = Message text to display "RTN","DGRPMS",162,0) ; LF1 = Number of line feeds to preceed the message "RTN","DGRPMS",163,0) ; L2F = Number of line feeds to follow the message "RTN","DGRPMS",164,0) ; "RTN","DGRPMS",165,0) N MSGARY,LFSTR "RTN","DGRPMS",166,0) S $P(LFSTR,"!",50)="!" "RTN","DGRPMS",167,0) S:$G(LF1)'="" MSGARY(.5,"F")=$E(LFSTR,1,(LF1-1)) "RTN","DGRPMS",168,0) S MSGARY(1)=MSGTXT "RTN","DGRPMS",169,0) S:$G(LF2)'="" MSGARY(2,"F")=$E(LFSTR,1,LF2) "RTN","DGRPMS",170,0) D EN^DDIOL(.MSGARY) "RTN","DGRPMS",171,0) Q "RTN","DGRPMS",172,0) ; "RTN","DGRPMS",173,0) CNFLCT ;; *** DO NOT REMOVE BELOW CONFLICT FIELD LOCATIONS *** "RTN","DGRPMS",174,0) ;; FROM DATE^TO DATE "RTN","DGRPMS",175,0) WWI ;; "RTN","DGRPMS",176,0) WWIIE ;; "RTN","DGRPMS",177,0) WWIIP ;; "RTN","DGRPMS",178,0) KOR ;; "RTN","DGRPMS",179,0) VIET ;;.32104^.32105 "RTN","DGRPMS",180,0) LEB ;;.3222^.3223 "RTN","DGRPMS",181,0) GREN ;;.3225^.3226 "RTN","DGRPMS",182,0) PAN ;;.3228^.3229 "RTN","DGRPMS",183,0) GULF ;;.322011^.322012 "RTN","DGRPMS",184,0) SOM ;;.322017^.322018 "RTN","DGRPMS",185,0) YUG ;;.32202^.322021 "RTN","DGRPMS",186,0) ;; "RTN","DGRPMS",187,0) ;; **BELOW VALUES ARE USED FOR MSE CHECKS - DO NOT REMOVE *** "RTN","DGRPMS",188,0) ;; ENTRY DATE^SEPERATION DATE "RTN","DGRPMS",189,0) MSL ;;.326^.327^.325 "RTN","DGRPMS",190,0) MSNTL ;;.3292^.3293^.3291 "RTN","DGRPMS",191,0) MSNNTL ;;.3297^.3298^.3296 "RTN","DGRPMS",192,0) ;; "RTN","DGRPMS",193,0) ;; **BELOW VALUES ARE USED FOR POW AND COMBAT CHECKS - DO NOT REMOVE "RTN","DGRPMS",194,0) ;; FROM DATE^TO DATE^LOCATION "RTN","DGRPMS",195,0) COMB ;;.5293^.5294^.5292 "RTN","DGRPMS",196,0) POW ;;.527^.528^.526 "RTN","DGRPMS",197,0) ;; "VER") 8.0^22 **END** **END**