Released DG*5.3*641 SEQ #576 Extracted from mail message **KIDS**:DG*5.3*641^ **INSTALL NAME** DG*5.3*641 "BLD",5988,0) DG*5.3*641^REGISTRATION^0^3050525^y "BLD",5988,1,0) ^^4^4^3050119^ "BLD",5988,1,1,0) This patch addresses the patient name lookup, cleans up variables left "BLD",5988,1,2,0) in the symbol table, allows the creation of VIC cards for patients without "BLD",5988,1,3,0) a first name, backs out the changes to the CUM ADC totals on the BSR, and "BLD",5988,1,4,0) creates cross-reference entries for test patients. "BLD",5988,4,0) ^9.64PA^^ "BLD",5988,"KRN",0) ^9.67PA^8989.52^19 "BLD",5988,"KRN",.4,0) .4 "BLD",5988,"KRN",.401,0) .401 "BLD",5988,"KRN",.402,0) .402 "BLD",5988,"KRN",.403,0) .403 "BLD",5988,"KRN",.5,0) .5 "BLD",5988,"KRN",.84,0) .84 "BLD",5988,"KRN",3.6,0) 3.6 "BLD",5988,"KRN",3.8,0) 3.8 "BLD",5988,"KRN",9.2,0) 9.2 "BLD",5988,"KRN",9.8,0) 9.8 "BLD",5988,"KRN",9.8,"NM",0) ^9.68A^7^7 "BLD",5988,"KRN",9.8,"NM",1,0) DGPMBSP2^^0^B20002914 "BLD",5988,"KRN",9.8,"NM",2,0) DGPMBSP3^^0^B14425800 "BLD",5988,"KRN",9.8,"NM",3,0) DGPMBSP4^^0^B6089525 "BLD",5988,"KRN",9.8,"NM",4,0) DGQEUT2^^0^B40537489 "BLD",5988,"KRN",9.8,"NM",5,0) DPTLK1^^0^B39062808 "BLD",5988,"KRN",9.8,"NM",6,0) DGRPC^^0^B24653446 "BLD",5988,"KRN",9.8,"NM",7,0) DG53P641^^0^B14532292 "BLD",5988,"KRN",9.8,"NM","B","DG53P641",7) "BLD",5988,"KRN",9.8,"NM","B","DGPMBSP2",1) "BLD",5988,"KRN",9.8,"NM","B","DGPMBSP3",2) "BLD",5988,"KRN",9.8,"NM","B","DGPMBSP4",3) "BLD",5988,"KRN",9.8,"NM","B","DGQEUT2",4) "BLD",5988,"KRN",9.8,"NM","B","DGRPC",6) "BLD",5988,"KRN",9.8,"NM","B","DPTLK1",5) "BLD",5988,"KRN",19,0) 19 "BLD",5988,"KRN",19.1,0) 19.1 "BLD",5988,"KRN",101,0) 101 "BLD",5988,"KRN",409.61,0) 409.61 "BLD",5988,"KRN",771,0) 771 "BLD",5988,"KRN",870,0) 870 "BLD",5988,"KRN",8989.51,0) 8989.51 "BLD",5988,"KRN",8989.52,0) 8989.52 "BLD",5988,"KRN",8994,0) 8994 "BLD",5988,"KRN","B",.4,.4) "BLD",5988,"KRN","B",.401,.401) "BLD",5988,"KRN","B",.402,.402) "BLD",5988,"KRN","B",.403,.403) "BLD",5988,"KRN","B",.5,.5) "BLD",5988,"KRN","B",.84,.84) "BLD",5988,"KRN","B",3.6,3.6) "BLD",5988,"KRN","B",3.8,3.8) "BLD",5988,"KRN","B",9.2,9.2) "BLD",5988,"KRN","B",9.8,9.8) "BLD",5988,"KRN","B",19,19) "BLD",5988,"KRN","B",19.1,19.1) "BLD",5988,"KRN","B",101,101) "BLD",5988,"KRN","B",409.61,409.61) "BLD",5988,"KRN","B",771,771) "BLD",5988,"KRN","B",870,870) "BLD",5988,"KRN","B",8989.51,8989.51) "BLD",5988,"KRN","B",8989.52,8989.52) "BLD",5988,"KRN","B",8994,8994) "BLD",5988,"QUES",0) ^9.62^^ "BLD",5988,"REQB",0) ^9.611^6^4 "BLD",5988,"REQB",2,0) DG*5.3*571^1 "BLD",5988,"REQB",4,0) DG*5.3*592^1 "BLD",5988,"REQB",5,0) DG*5.3*585^1 "BLD",5988,"REQB",6,0) DG*5.3*620^1 "BLD",5988,"REQB","B","DG*5.3*571",2) "BLD",5988,"REQB","B","DG*5.3*585",5) "BLD",5988,"REQB","B","DG*5.3*592",4) "BLD",5988,"REQB","B","DG*5.3*620",6) "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) 641^3050525 "PKG",5,22,1,"PAH",1,1,0) ^^4^4^3050525 "PKG",5,22,1,"PAH",1,1,1,0) This patch addresses the patient name lookup, cleans up variables left "PKG",5,22,1,"PAH",1,1,2,0) in the symbol table, allows the creation of VIC cards for patients without "PKG",5,22,1,"PAH",1,1,3,0) a first name, backs out the changes to the CUM ADC totals on the BSR, and "PKG",5,22,1,"PAH",1,1,4,0) creates cross-reference entries for test patients. "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") 7 "RTN","DG53P641") 0^7^B14532292 "RTN","DG53P641",1,0) DG53P641 ;BAY/JAT - Patient File Updat; 6/7/04 7:13pm ; 1/4/05 5:06pm "RTN","DG53P641",2,0) ;;5.3;Registration;**641**;Aug 13,1993 "RTN","DG53P641",3,0) Q "RTN","DG53P641",4,0) ; "RTN","DG53P641",5,0) CLEANUP ;This entry point will do the update. "RTN","DG53P641",6,0) ; "RTN","DG53P641",7,0) N DGENSKIP "RTN","DG53P641",8,0) S DGENSKIP=0 "RTN","DG53P641",9,0) W !,"This is a one-time update of the Patient File." "RTN","DG53P641",10,0) W !,"It will set the 'ATEST' cross-reference as needed." "RTN","DG53P641",11,0) N X1,X2 "RTN","DG53P641",12,0) K ^XTMP("DG53P641",$J) "RTN","DG53P641",13,0) S X1=DT,X2=90 D C^%DTC "RTN","DG53P641",14,0) S ^XTMP("DG53P641",$J,0)=X_"^"_DT_"^Patient File update" "RTN","DG53P641",15,0) I $$DEVICE() D ENTER "RTN","DG53P641",16,0) Q "RTN","DG53P641",17,0) ; "RTN","DG53P641",18,0) REPORT ;This entry point was provided for testing, so that before "RTN","DG53P641",19,0) ;patient records are updated the site can have a list of "RTN","DG53P641",20,0) ;the DFN's that would be affected. "RTN","DG53P641",21,0) ; "RTN","DG53P641",22,0) ;Use this entry point to report on what the update would do. "RTN","DG53P641",23,0) ;No changes will be made to the database. "RTN","DG53P641",24,0) ; "RTN","DG53P641",25,0) N DGENSKIP "RTN","DG53P641",26,0) S DGENSKIP=1 "RTN","DG53P641",27,0) W !,"This is a preliminary report by DFN of the Patient file" "RTN","DG53P641",28,0) W !,"records which would be affected by the update." "RTN","DG53P641",29,0) N X1,X2 "RTN","DG53P641",30,0) K ^XTMP("DG53P641",$J) "RTN","DG53P641",31,0) S X1=DT,X2=90 D C^%DTC "RTN","DG53P641",32,0) S ^XTMP("DG53P641",$J,0)=X_"^"_DT_"^Patient File update" "RTN","DG53P641",33,0) I $$DEVICE() D ENTER "RTN","DG53P641",34,0) Q "RTN","DG53P641",35,0) ; "RTN","DG53P641",36,0) ENTER ; "RTN","DG53P641",37,0) ; "RTN","DG53P641",38,0) D UPDATE(DGENSKIP) "RTN","DG53P641",39,0) D:(DGENSKIP) ^%ZISC "RTN","DG53P641",40,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","DG53P641",41,0) Q "RTN","DG53P641",42,0) DEVICE() ; "RTN","DG53P641",43,0) ;Description: allows the user to select a device. "RTN","DG53P641",44,0) ; "RTN","DG53P641",45,0) ;Output: "RTN","DG53P641",46,0) ; Function Value - Returns 0 if the user decides not to print or to "RTN","DG53P641",47,0) ; queue the report, 1 otherwise. "RTN","DG53P641",48,0) ; "RTN","DG53P641",49,0) N OK,IOP,POP,%ZIS "RTN","DG53P641",50,0) S OK=1 "RTN","DG53P641",51,0) S %ZIS="MQ" "RTN","DG53P641",52,0) D ^%ZIS "RTN","DG53P641",53,0) S:POP OK=0 "RTN","DG53P641",54,0) D:OK&$D(IO("Q")) "RTN","DG53P641",55,0) .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP "RTN","DG53P641",56,0) .S ZTRTN="ENTER^DG53P641",ZTDESC=$S(DGENSKIP:"Report",1:"Update")_" of Patient Records" "RTN","DG53P641",57,0) .S ZTSAVE("DGENSKIP")="" "RTN","DG53P641",58,0) .D ^%ZTLOAD "RTN","DG53P641",59,0) .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") "RTN","DG53P641",60,0) .D HOME^%ZIS "RTN","DG53P641",61,0) .S OK=0 "RTN","DG53P641",62,0) Q OK "RTN","DG53P641",63,0) ; "RTN","DG53P641",64,0) UPDATE(DGENSKIP) ; "RTN","DG53P641",65,0) ;This will update patient records -- "RTN","DG53P641",66,0) ; "RTN","DG53P641",67,0) ;Input: If DGENSKIP=1, the records will not be updated, "RTN","DG53P641",68,0) ;just reported. "RTN","DG53P641",69,0) ; "RTN","DG53P641",70,0) N DFN,COUNT,DGSSN,DGS,DGFLG,DGXREF,DGVAL,DGFDA,DGERR "RTN","DG53P641",71,0) S (COUNT,DFN)=0 "RTN","DG53P641",72,0) F S DFN=$O(^DPT(DFN)) Q:'DFN D "RTN","DG53P641",73,0) .; merged record "RTN","DG53P641",74,0) .I $D(^DPT(DFN,-9)) Q "RTN","DG53P641",75,0) .; in process of being merged "RTN","DG53P641",76,0) .I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q "RTN","DG53P641",77,0) .I $D(^DPT(DFN,0)) D "RTN","DG53P641",78,0) ..S DGSSN=$P($G(^DPT(DFN,0)),U,9) "RTN","DG53P641",79,0) ..Q:'DGSSN "RTN","DG53P641",80,0) ..Q:$E(DGSSN,1,5)'="00000" "RTN","DG53P641",81,0) ..Q:$D(^DPT("ATEST",DFN)) "RTN","DG53P641",82,0) ..D UPDR "RTN","DG53P641",83,0) ; "RTN","DG53P641",84,0) D PRINT "RTN","DG53P641",85,0) Q "RTN","DG53P641",86,0) ; "RTN","DG53P641",87,0) UPDR ; "RTN","DG53P641",88,0) S COUNT=COUNT+1 "RTN","DG53P641",89,0) S ^XTMP("DG53P641",$J,DFN)=DGSSN "RTN","DG53P641",90,0) I 'DGENSKIP D "RTN","DG53P641",91,0) .N DA,DIK "RTN","DG53P641",92,0) .S DA=DFN,DIK="^DPT(",DIK(1)=".09^ATP" "RTN","DG53P641",93,0) .D EN1^DIK "RTN","DG53P641",94,0) Q "RTN","DG53P641",95,0) PRINT ; "RTN","DG53P641",96,0) U IO "RTN","DG53P641",97,0) N DGDDT,DGQUIT,DGPG "RTN","DG53P641",98,0) S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D") "RTN","DG53P641",99,0) S (DGQUIT,DGPG)=0 "RTN","DG53P641",100,0) D HEAD "RTN","DG53P641",101,0) I '$G(COUNT) D Q "RTN","DG53P641",102,0) .W !!!,?20,"*** No records to report ***" "RTN","DG53P641",103,0) W !!,"*** COUNT OF BAD PATIENT RECORDS"_$S(DGENSKIP:"",1:" UPDATED")_": ",COUNT," ***",!! "RTN","DG53P641",104,0) S DFN=0 "RTN","DG53P641",105,0) F S DFN=$O(^XTMP("DG53P641",$J,DFN)) Q:'DFN D Q:DGQUIT "RTN","DG53P641",106,0) .I $Y>(IOSL-4) D HEAD "RTN","DG53P641",107,0) .S DGSSN=$P($G(^XTMP("DG53P641",$J,DFN)),U) "RTN","DG53P641",108,0) .W ?2,DFN,?15,DGSSN,! "RTN","DG53P641",109,0) ; "RTN","DG53P641",110,0) I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q "RTN","DG53P641",111,0) I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 "RTN","DG53P641",112,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","DG53P641",113,0) Q "RTN","DG53P641",114,0) ; "RTN","DG53P641",115,0) HEAD ; "RTN","DG53P641",116,0) I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q "RTN","DG53P641",117,0) I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 "RTN","DG53P641",118,0) Q:DGQUIT "RTN","DG53P641",119,0) S DGPG=$G(DGPG)+1 "RTN","DG53P641",120,0) W @IOF,!,DGDDT,?15,"DG*5.3*641 Patient File Update Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,! "RTN","DG53P641",121,0) W ! "RTN","DG53P641",122,0) W !,?2,"DFN",?15,"SSN",! "RTN","DG53P641",123,0) S $P(X,"-",81)="" W X,! "RTN","DG53P641",124,0) Q "RTN","DGPMBSP2") 0^1^B20002914 "RTN","DGPMBSP2",1,0) DGPMBSP2 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90 ; 1/13/05 3:48pm "RTN","DGPMBSP2",2,0) ;;5.3;Registration;**59,592,641**;Aug 13, 1993 "RTN","DGPMBSP2",3,0) ; "RTN","DGPMBSP2",4,0) A S BD=1 S BD("DY")=BD("OSD") ;(BD*BD("M")) ; Total Elapsed Fiscal Days * Bed Days Multipler "RTN","DGPMBSP2",5,0) S ^UTILITY("DGWBD",$J,+ORDER)=BD("DY")_"^"_BD("S")_"^"_BD("D")_"^"_BD("CB") ; Total Elapsed Fiscal Days * Bed Days Multipler_^_Include Stat's_^_Display on BSR_^_Cum Beds "RTN","DGPMBSP2",6,0) Q:'BD("S") ; Include Stat's "RTN","DGPMBSP2",7,0) ; "RTN","DGPMBSP2",8,0) CENSUS S X=$S($D(^DG(41.9,W,"C",RD,0)):^(0),1:"") ; Census File 0 Node (Report Date) NEW NODE "RTN","DGPMBSP2",9,0) S ^UTILITY("DGWNN",$J,ORDER)=X ; Census File 0 Node (Report Date) NEW NODE "RTN","DGPMBSP2",10,0) S ^UTILITY("DGWON",$J,ORDER)=$S($D(^DG(41.9,W,"C",FY("L"),0)):^(0),1:"") ; Census File 0 Node (last fiscal year) OLD NODE "RTN","DGPMBSP2",11,0) S X(1)=$S($D(^DG(41.9,W,"C",RD,1)):^(1),1:"") ; Census File 1 Node (Report Date) "RTN","DGPMBSP2",12,0) S X1=$S($D(^DG(41.9,W,"C",PD,0)):^(0),1:"") ; Census File 0 Node (Previous Date) "RTN","DGPMBSP2",13,0) S:$E(PD,4,7)="0930" X1="^"_$P(X1,"^",2) ; Pats Remaining "RTN","DGPMBSP2",14,0) ; "RTN","DGPMBSP2",15,0) PM S BD("PM")=$S($D(^DG(41.9,W,"C",FY("EOM"),0)):+$P(^(0),"^",3),1:0) ; Cum Pat Days of Care "RTN","DGPMBSP2",16,0) S:$E(FY("EOM"),4,7)="0930" BD("PM")=0 "RTN","DGPMBSP2",17,0) ; "RTN","DGPMBSP2",18,0) N ; BD("N") = BSR Display Stat's Node ; $P(1,2)=Name of Ward^Bed Section "RTN","DGPMBSP2",19,0) S $P(BD("N"),"^",3)=+$P(X1,"^",2) ; Pats Remaining (Previous Date) "RTN","DGPMBSP2",20,0) S $P(BD("N"),"^",4)=$P(X,"^",28)-$P(X1,"^",28) ; Gains Total Cum (new) - Gains Total Cum (previous) "RTN","DGPMBSP2",21,0) S $P(BD("N"),"^",5)=$P(X,"^",24)-$P(X1,"^",24) ; losses (new) - losses (previous) "RTN","DGPMBSP2",22,0) S $P(BD("N"),"^",6)=+$P(X,"^",2) ; Pats Remaining "RTN","DGPMBSP2",23,0) S $P(BD("N"),"^",7)=+$P(X(1),"^",5) ; AA<96 "RTN","DGPMBSP2",24,0) S $P(BD("N"),"^",8)=+$P(X(1),"^",6) ; AA "RTN","DGPMBSP2",25,0) S $P(BD("N"),"^",9)=+$P(X(1),"^",7) ; UA "RTN","DGPMBSP2",26,0) S $P(BD("N"),"^",10)=+$P(X(1),"^",8) ; ASIH "RTN","DGPMBSP2",27,0) ; "RTN","DGPMBSP2",28,0) BEDS S BD("DOS")=+$P(X(1),"^",9) ; Beds OOS "RTN","DGPMBSP2",29,0) S BD("AB")=+$P(X(1),"^",10) ; Auth Beds "RTN","DGPMBSP2",30,0) S X(2)=(BD("AB")-BD("DOS")) ; Auth Beds - Bed OOS "RTN","DGPMBSP2",31,0) S $P(BD("N"),"^",11)=$S(BD("AB")&($P(X,"^",2)'>X(2)):(BD("AB")-($P(X,"^",2)+BD("DOS"))),1:0) ; AB=Auth Bed - Pat Remaining + Beds OOS = Vacant Beds "RTN","DGPMBSP2",32,0) S $P(BD("N"),"^",12)=+BD("DOS") ; Beds OOS "RTN","DGPMBSP2",33,0) S $P(BD("N"),"^",13)=$P(X(1),"^",2) ; Operation Beds "RTN","DGPMBSP2",34,0) S $P(BD("N"),"^",14)=$S($P(X,"^",2)'>X(2):0,1:$P(X,"^",2)-X(2)) ; Pats Remaining greater than Auth Bed - Bed OOS = Over Cap Beds "RTN","DGPMBSP2",35,0) S $P(BD("N"),"^",15)=BD("AB") ; AB=Auth Bed "RTN","DGPMBSP2",36,0) ; "RTN","DGPMBSP2",37,0) ADC S BD("P")=+$P(X,"^",3) ; Cum Pat Days of Care (new) "RTN","DGPMBSP2",38,0) ;S X(2)=(BD("P")/FY("D")) ; Cum Pat Days of Care/Days into Fiscal Year (Cum Ave Daily Census) "RTN","DGPMBSP2",39,0) S X(2)=$S(FY("D")-BD("OSD"):BD("P")/(FY("D")-BD("OSD")),1:0) ; Pat Days/Total Elapsed Fiscal Days - days OOS (Cum ADC*) "RTN","DGPMBSP2",40,0) S X(3)=(BD("P")*100) ; Cum Pat Days of Care * 100 "RTN","DGPMBSP2",41,0) ; "RTN","DGPMBSP2",42,0) S BD("OR")=$S(BD("CB")>0:(X(3)/BD("CB")),1:0) ; Cum Beds >0 then Pat Days of Care * 100 divided by Cum Beds (Cum Occ. Rate) "RTN","DGPMBSP2",43,0) S $P(BD("N"),"^",16)=$J(X(2),0,1) ; Cum ADC "RTN","DGPMBSP2",44,0) S $P(BD("N"),"^",17)=$J(BD("OR"),0,1)_"%" ; Cum Occ. Rate "RTN","DGPMBSP2",45,0) S $P(BD("N"),"^",18)=BD("P") ; Cum Pat Days of Care (new) ADC "RTN","DGPMBSP2",46,0) ; "RTN","DGPMBSP2",47,0) OOS ; OOS stats "RTN","DGPMBSP2",48,0) S X(2)=$S(FY("D")-BD("OSD"):BD("P")/(FY("D")-BD("OSD")),1:0) ; Pat Days/Total Elapsed Fiscal Days - days OOS (Cum ADC*) "RTN","DGPMBSP2",49,0) S X(3)=(BD("P")*100) ; Pat Days * 100 "RTN","DGPMBSP2",50,0) ; *Occ Rate is *ADC multiplied by 100 divided by FYTD-OOS days "RTN","DGPMBSP2",51,0) S BD("OOR")=$S(BD("CB")>0:(X(3)/BD("CB")),1:0) ; Cum Beds >0 then Pat Days of Care * 100 divided by Cum Beds (Cum Occ. Rate*) "RTN","DGPMBSP2",52,0) ; "RTN","DGPMBSP2",53,0) NODE S ^UTILITY("DGWOR",$J,ORDER)=BD("N") ; BSR Display Stat's Node "RTN","DGPMBSP2",54,0) S ADC=+BD("P")_"^"_(+BD("P")-(BD("PM"))) ; Cum Pat Days of Care new ADC _^_ Cum Pat Days of Care new ADC _^_ Cum Pt Day of Care FY "RTN","DGPMBSP2",55,0) F X=1:1:2 S $P(ADC(BD("DV"),BD("ADC")),"^",X)=$P(ADC(BD("DV"),BD("ADC")),"^",X)+$P(ADC,"^",X) ; BD("DV") = Division BD("ADC") = Service Type "RTN","DGPMBSP2",56,0) S X=^UTILITY("DGWPL",$J,BD("PL")) ; BD("PL") = Primary Location "RTN","DGPMBSP2",57,0) F I=3:1:15,18 S $P(X,"^",I)=$P(X,"^",I)+$P(BD("N"),"^",I) "RTN","DGPMBSP2",58,0) ; "RTN","DGPMBSP2",59,0) SET S ^UTILITY("DGWPL",$J,BD("PL"))=X ; Ward totals "RTN","DGPMBSP2",60,0) S X=^UTILITY("DGWPLT",$J,BD("PL")) "RTN","DGPMBSP2",61,0) S $P(X,"^")=$P(X,"^")+1 "RTN","DGPMBSP2",62,0) S $P(X,"^",2)=$P(X,"^",2)+BD("DY") ; Total elasped fiscal days * bed day multipler "RTN","DGPMBSP2",63,0) S $P(X,"^",3)=$P(X,"^",3)+BD("CB") ; Cum beds "RTN","DGPMBSP2",64,0) S ^UTILITY("DGWPLT",$J,BD("PL"))=X ; Total of wards _^_ Total elapsed fiscal days * bed days multipler _^_ Cum bed "RTN","DGPMBSP2",65,0) Q Q "RTN","DGPMBSP3") 0^2^B14425800 "RTN","DGPMBSP3",1,0) DGPMBSP3 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 1/13/05 3:48pm "RTN","DGPMBSP3",2,0) ;;5.3;Registration;**59,85,529,592,641**;Aug 13, 1993 "RTN","DGPMBSP3",3,0) ; "RTN","DGPMBSP3",4,0) A S NTOTAL="",(ORDER,CW,CB,CUM,BD,CT)=0 "RTN","DGPMBSP3",5,0) ; ^UTILITY("DGWOR",$J,ORDER)=19 PIECE PRINT/STATS LINE "RTN","DGPMBSP3",6,0) F O1=0:0 S ORDER=$O(^UTILITY("DGWOR",$J,ORDER)) Q:ORDER'>0 S DGWOR=^(ORDER),BDAY=$S($D(^UTILITY("DGWBD",$J,ORDER)):^(ORDER),1:0) D WR "RTN","DGPMBSP3",7,0) K BD,BDAY,C,CB,CW,I,I1,L,N,N1,ORDER,O1,TL,W,X,X1,Y,T,T1,T2,T3,TN,TX,TY,DGWOR,DGWON,DGWNN,DGWTOR "RTN","DGPMBSP3",8,0) Q Q "RTN","DGPMBSP3",9,0) ; "RTN","DGPMBSP3",10,0) ; $P(BDAY,"^",3) = Display on BSR "RTN","DGPMBSP3",11,0) WR I $P(BDAY,"^",3) W ! F W=1:1:18 W ?+$P(TAB,"^",W),$J($P(DGWOR,"^",W),$P(JUS,"^",W)) "RTN","DGPMBSP3",12,0) ; $P(BDAY,"^",2) = Include Stats "RTN","DGPMBSP3",13,0) I $P(BDAY,"^",2) D CUM F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(DGWOR,"^",N1) "RTN","DGPMBSP3",14,0) Q:$O(^UTILITY("DGWTOR",$J,ORDER,0))'>0 "RTN","DGPMBSP3",15,0) S TL=0 "RTN","DGPMBSP3",16,0) ; ^UTILITY("DGWTOR",$J,ORDER,TOTAL LEVEL)=TOTAL NAME ^ PRINT IN CUM TOTALS (ORDER TOTAL) "RTN","DGPMBSP3",17,0) F TL1=0:0 S TL=$O(^UTILITY("DGWTOR",$J,ORDER,TL)) Q:TL'>0 S DGWTOR=^(TL) D TL "RTN","DGPMBSP3",18,0) Q "RTN","DGPMBSP3",19,0) ; "RTN","DGPMBSP3",20,0) CUM S CW=CW+1 ; Count Ward "RTN","DGPMBSP3",21,0) S CB=CB+$P(BDAY,"^",4) ; Cum Beds "RTN","DGPMBSP3",22,0) S BD=BD+BDAY ; Total Elapsed Fiscal Days "RTN","DGPMBSP3",23,0) S DGWON=$S($D(^UTILITY("DGWON",$J,ORDER)):^(ORDER),1:0) ; Last year 0 Node for ward (Old Node) "RTN","DGPMBSP3",24,0) S DGWNN=$S($D(^UTILITY("DGWNN",$J,ORDER)):^(ORDER),1:0) ; RD's 0 Node for Ward (New Node) "RTN","DGPMBSP3",25,0) S C=0 "RTN","DGPMBSP3",26,0) F I=17,29,23,5,6,8,3 F I1=DGWON,DGWNN S C=C+1,$P(CUM,"^",C)=$P(CUM,"^",C)+$P(I1,"^",I) "RTN","DGPMBSP3",27,0) ; CUM=old cum adm^new cum adm^old IWT^new IWT^old cum inter svc xfrs in^new cum inter svc xfers in^old cum disch^new cum disch^old cum inter xfers^new cum inter xfers^old inter svc xfers^new inter svc xfers^old cum bed^new cum bed "RTN","DGPMBSP3",28,0) Q "RTN","DGPMBSP3",29,0) ; "RTN","DGPMBSP3",30,0) TL S TC(TL,ORDER)=CUM "RTN","DGPMBSP3",31,0) S TL(TL,ORDER)=NTOTAL "RTN","DGPMBSP3",32,0) S TB(TL,ORDER)=BD_"^"_CW_"^"_CB ; TOTAL ELAPSED FISCAL DAYS ^ COUNT WARD ^ CUM BED "RTN","DGPMBSP3",33,0) I TL=1 S W=NTOTAL,T2=ORDER D TWR Q "RTN","DGPMBSP3",34,0) S NTOTAL="",T=0 "RTN","DGPMBSP3",35,0) F T1=0:0 S T=$O(TL(TL-1,T)) Q:T'>0!(T>ORDER) S T2=T,TN=TL(TL-1,T),TX=TB(TL-1,T),TY=TC(TL-1,T) D MTL "RTN","DGPMBSP3",36,0) S:$P(DGWTOR,"^",2) CUM(T2,TL)=$P(DGWTOR,"^")_"^"_TC(TL,T2),CT=CT+1 ; CT=CUM TOTAL "RTN","DGPMBSP3",37,0) S CUM="",(W,TL(TL,T2))=NTOTAL D TWR "RTN","DGPMBSP3",38,0) Q "RTN","DGPMBSP3",39,0) ; "RTN","DGPMBSP3",40,0) TWR N DGDNTD "RTN","DGPMBSP3",41,0) S DGDNTD=$S($P(DGWTOR,"^")["DON'T DISPLAY":1,1:0) "RTN","DGPMBSP3",42,0) I DGDNTD,TL=1 W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP3",43,0) I 'DGDNTD D "RTN","DGPMBSP3",44,0) .W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP3",45,0) .W ! "RTN","DGPMBSP3",46,0) .D PTOT ; print line on BSR "RTN","DGPMBSP3",47,0) ; code below updates cums "RTN","DGPMBSP3",48,0) S (CB,BD,CW,NTOTAL)="" "RTN","DGPMBSP3",49,0) I $S('$P(DGWTOR,"^",2):1,TL'=1:1,1:0) S CUM="" Q "RTN","DGPMBSP3",50,0) S CUM(ORDER,TL)=$P(DGWTOR,"^")_"^"_CUM "RTN","DGPMBSP3",51,0) S CUM="" "RTN","DGPMBSP3",52,0) S CT=CT+1 ; CUM TOTAL "RTN","DGPMBSP3",53,0) Q "RTN","DGPMBSP3",54,0) ; "RTN","DGPMBSP3",55,0) PTOT ; Calc Vacant, Overcapacity Beds for Totals "RTN","DGPMBSP3",56,0) S $P(W,"^",11)=$S(+$P(W,"^",13)>+$P(W,"^",6):($P(W,"^",13)-$P(W,"^",6)),1:0) ; Vacant Beds = Operating Beds - Patients Remaining "RTN","DGPMBSP3",57,0) S $P(W,"^",14)=$S(+$P(W,"^",6)>+$P(W,"^",13):($P(W,"^",6)-$P(W,"^",13)),1:0) ; Overcapacity = Patients Remaining - Operating Beds "RTN","DGPMBSP3",58,0) W $P(DGWTOR,"^") ; Total (level name) "RTN","DGPMBSP3",59,0) F I=3:1:15 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^",I)) "RTN","DGPMBSP3",60,0) S X(16)=($P(W,"^",18)/FY("D")) ; Cum Pat Days/Days into fiscal year "RTN","DGPMBSP3",61,0) S X(17)=$S($P(TB(TL,T2),"^",3)'>0:0,1:((X(16)*100)/($P(TB(TL,T2),"^",3)/FY("D")))) ; ADC/(Cum Bed Total/Days into fiscal year) "RTN","DGPMBSP3",62,0) S X(16)=$J(X(16),0,1) ; Cum ADC "RTN","DGPMBSP3",63,0) S X(17)=$J(X(17),0,1)_"%" ; Cum Occ Rate "RTN","DGPMBSP3",64,0) S X(18)=$P(W,"^",18) ; Cum Pat Days "RTN","DGPMBSP3",65,0) F I=16:1:18 W ?+$P(TAB,"^",I),$J(X(I),$P(JUS,"^",I)) "RTN","DGPMBSP3",66,0) W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP3",67,0) I $Y>$S($D(IOSL):(IOSL-5),1:61) D HEAD^DGPMBSP,HEAD2^DGPMBSP "RTN","DGPMBSP3",68,0) Q "RTN","DGPMBSP3",69,0) ; "RTN","DGPMBSP3",70,0) MTL F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(TN,"^",N1) "RTN","DGPMBSP3",71,0) S T3=$O(TB(TL,T)) "RTN","DGPMBSP3",72,0) I T'>T3 S T2=T3 "RTN","DGPMBSP3",73,0) F N1=1:1:3 S $P(TB(TL,T2),"^",N1)=$P(TB(TL,T2),"^",N1)+$P(TX,"^",N1) "RTN","DGPMBSP3",74,0) I $P(DGWTOR,"^",2) F N1=1:1:15 S $P(TC(TL,T2),"^",N1)=$P(TC(TL,T2),"^",N1)+$P(TY,"^",N1) "RTN","DGPMBSP3",75,0) K TC(TL-1,T),TL(TL-1,T),TB(TL-1,T),N1,T3 "RTN","DGPMBSP3",76,0) Q "RTN","DGPMBSP4") 0^3^B6089525 "RTN","DGPMBSP4",1,0) DGPMBSP4 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 1/13/05 3:48pm "RTN","DGPMBSP4",2,0) ;;5.3;Registration;**592,641**;Aug 13, 1993 "RTN","DGPMBSP4",3,0) ; "RTN","DGPMBSP4",4,0) A Q:'PL "RTN","DGPMBSP4",5,0) ; "RTN","DGPMBSP4",6,0) S X="T O T A L S B Y P R I M A R Y W A R D L O C A T I O N" "RTN","DGPMBSP4",7,0) ; "RTN","DGPMBSP4",8,0) W ! W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP4",9,0) W !?0,"|",?(RM-$L(X)\2),X,?130,"|" "RTN","DGPMBSP4",10,0) W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP4",11,0) ; "RTN","DGPMBSP4",12,0) HEAD2 W !?0,"|",?71,"Va-",?92,"Over",?116,"Cum",?127,"Cum|" "RTN","DGPMBSP4",13,0) W !?0,"|",?2,"Primary",?21,"Prev",?39,"Pt's",?71,"cant",?78,"Beds",?85,"Oper",?92,"Cap.",?100,"Auth",?108,"Cum",?116,"Occ.",?123,"Patient|" "RTN","DGPMBSP4",14,0) W !?0,"|",?2,"Location",?21,"Rem.",?27,"Gain",?33,"Loss",?39,"Rem.",?45,"Pass",?53,"AA",?59,"UA",?64,"ASIH",?71,"Beds",?79,"OOS",?85,"Beds",?92,"Beds",?100,"Beds",?108,"ADC",?116,"Rate",?126,"Days|" "RTN","DGPMBSP4",15,0) W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP4",16,0) ; "RTN","DGPMBSP4",17,0) S I=0 F I1=0:0 S I=$O(^UTILITY("DGWPL",$J,I)) Q:I="" S X=^(I),X1=$S($D(^UTILITY("DGWPLT",$J,I)):^(I),1:0) D WR "RTN","DGPMBSP4",18,0) W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL "RTN","DGPMBSP4",19,0) K I,I1,X1,L "RTN","DGPMBSP4",20,0) HEAD2Q Q "RTN","DGPMBSP4",21,0) ; "RTN","DGPMBSP4",22,0) WR W !?0,"|",I "RTN","DGPMBSP4",23,0) S $P(X,"^",11)=$S(+$P(X,"^",13)>+$P(X,"^",6):($P(X,"^",13)-$P(X,"^",6)),1:0) ; Vacant Beds = Operating Beds - Patients Remaining "RTN","DGPMBSP4",24,0) S $P(X,"^",14)=$S(+$P(X,"^",6)>+$P(X,"^",13):($P(X,"^",6)-$P(X,"^",13)),1:0) ; Overcapacity = Patients Remaining - Operating Beds "RTN","DGPMBSP4",25,0) F N=3:1:15 W ?+$P(TAB,"^",N),$J($P(X,"^",N),+$P(JUS,"^",N)) "RTN","DGPMBSP4",26,0) S X(16)=($P(X,"^",18)/FY("D")) "RTN","DGPMBSP4",27,0) S X2=$P(X1,"^",3)/FY("D") "RTN","DGPMBSP4",28,0) S X(17)=$S(X2'>0:0,1:((X(16)*100)/X2)) "RTN","DGPMBSP4",29,0) S X(16)=$J(X(16),0,1) "RTN","DGPMBSP4",30,0) S X(17)=$J(X(17),0,1)_"%" "RTN","DGPMBSP4",31,0) S X(18)=+$P(X,"^",18) "RTN","DGPMBSP4",32,0) S X2=$P(X1,"^",2)/$P(X1,"^") "RTN","DGPMBSP4",33,0) F N=16:1:18 W ?+$P(TAB,"^",N),$J(X(N),$P(JUS,"^",N)) "RTN","DGPMBSP4",34,0) W ?30,"|" "RTN","DGPMBSP4",35,0) WRQ Q "RTN","DGQEUT2") 0^4^B40537489 "RTN","DGQEUT2",1,0) DGQEUT2 ;ALB/RPM - VIC REPLACEMENT UTILITIES #2 ; 1/19/05 11:52am "RTN","DGQEUT2",2,0) ;;5.3;Registration;**571,641**;Aug 13, 1993 "RTN","DGQEUT2",3,0) ; "RTN","DGQEUT2",4,0) ; This routine contains the following VIC Redesign API's: "RTN","DGQEUT2",5,0) ; CPRSTAT - determine Card Print Release Status "RTN","DGQEUT2",6,0) ; $$PENDDT - checks for pending requests and returns request date "RTN","DGQEUT2",7,0) ; $$REQFLD - checks for required fields "RTN","DGQEUT2",8,0) ; $$HOLD - checks for pending ICN and/or Enrollment "RTN","DGQEUT2",9,0) ; $$VICELIG - determines applicant's VIC eligibility "RTN","DGQEUT2",10,0) ; "RTN","DGQEUT2",11,0) Q ;no direct entry "RTN","DGQEUT2",12,0) ; "RTN","DGQEUT2",13,0) ; "RTN","DGQEUT2",14,0) CPRSTAT(DGVIC) ;determine card print release status "RTN","DGQEUT2",15,0) ; This procedure is used to determine Card Print Release Status from "RTN","DGQEUT2",16,0) ; the data contained in the input array (DGVIC). Once determined, the "RTN","DGQEUT2",17,0) ; status and remarks are placed into the VIC data array. "RTN","DGQEUT2",18,0) ; "RTN","DGQEUT2",19,0) ; Input: "RTN","DGQEUT2",20,0) ; DGVIC - VIC data array (pass by reference) "RTN","DGQEUT2",21,0) ; "RTN","DGQEUT2",22,0) ; Output: None "RTN","DGQEUT2",23,0) ; "RTN","DGQEUT2",24,0) N DGERR "RTN","DGQEUT2",25,0) ; "RTN","DGQEUT2",26,0) D ;drop out of DO block when DGVIC("STAT") is known "RTN","DGQEUT2",27,0) . ; "RTN","DGQEUT2",28,0) . ;check if DFN is valid "RTN","DGQEUT2",29,0) . ;set card print release status="C"ancel if not valid "RTN","DGQEUT2",30,0) . I '$D(^DPT(+$G(DGVIC("DFN")),0)) D "RTN","DGQEUT2",31,0) . . S DGVIC("STAT")="C" "RTN","DGQEUT2",32,0) . . S DGVIC("REMARKS")="Unable to find veteran in the database" "RTN","DGQEUT2",33,0) . Q:DGVIC("STAT")]"" "RTN","DGQEUT2",34,0) . ; "RTN","DGQEUT2",35,0) . ;check for required fields "RTN","DGQEUT2",36,0) . ;set card print release status="C"ancel if req field is missing "RTN","DGQEUT2",37,0) . I '$$REQFLD(.DGVIC,.DGERR) D "RTN","DGQEUT2",38,0) . . S DGVIC("STAT")="C" "RTN","DGQEUT2",39,0) . . S DGVIC("REMARKS")=$G(DGERR) "RTN","DGQEUT2",40,0) . Q:DGVIC("STAT")]"" "RTN","DGQEUT2",41,0) . ; "RTN","DGQEUT2",42,0) . ;check ICN and Enrollment Status "RTN","DGQEUT2",43,0) . ;set card print release status="H"old when either is pending "RTN","DGQEUT2",44,0) . I $$HOLD(.DGVIC,.DGERR) D "RTN","DGQEUT2",45,0) . . S DGVIC("STAT")="H" "RTN","DGQEUT2",46,0) . . S DGVIC("REMARKS")=$G(DGERR) "RTN","DGQEUT2",47,0) . Q:DGVIC("STAT")]"" "RTN","DGQEUT2",48,0) . ; "RTN","DGQEUT2",49,0) . ;check if pt is eligible for VIC "RTN","DGQEUT2",50,0) . ;set card print release status="P"rint if eligible, else "I"neligible "RTN","DGQEUT2",51,0) . I $$VICELIG(.DGVIC) S DGVIC("STAT")="P" "RTN","DGQEUT2",52,0) . E D "RTN","DGQEUT2",53,0) . . S DGVIC("STAT")="I" "RTN","DGQEUT2",54,0) . . S DGVIC("REMARKS")="Veteran does not meet VIC eligibility requirements." "RTN","DGQEUT2",55,0) ; "RTN","DGQEUT2",56,0) Q "RTN","DGQEUT2",57,0) ; "RTN","DGQEUT2",58,0) ; "RTN","DGQEUT2",59,0) PENDDT(DGDFN) ;check for pending request date "RTN","DGQEUT2",60,0) ; "RTN","DGQEUT2",61,0) ; Input: "RTN","DGQEUT2",62,0) ; DGDFN - pointer to patient in PATIENT (#2) file "RTN","DGQEUT2",63,0) ; "RTN","DGQEUT2",64,0) ; Output: "RTN","DGQEUT2",65,0) ; Function value - FM format request date on success, 0 on failure "RTN","DGQEUT2",66,0) ; "RTN","DGQEUT2",67,0) N DGDAT ;function value "RTN","DGQEUT2",68,0) N DGRIEN ;VIC REQUEST pointer "RTN","DGQEUT2",69,0) N DGREQ ;array of request data "RTN","DGQEUT2",70,0) ; "RTN","DGQEUT2",71,0) S DGDAT=0 "RTN","DGQEUT2",72,0) ; "RTN","DGQEUT2",73,0) ;get last request "RTN","DGQEUT2",74,0) S DGRIEN=$$FINDLST^DGQEREQ(DGDFN) "RTN","DGQEUT2",75,0) I DGRIEN D "RTN","DGQEUT2",76,0) . Q:'$$GETREQ^DGQEREQ(DGRIEN,.DGREQ) "RTN","DGQEUT2",77,0) . ; "RTN","DGQEUT2",78,0) . ;check Card Print Release Status "RTN","DGQEUT2",79,0) . I $G(DGREQ("CPRSTAT"))="H" S DGDAT=+$G(DGREQ("REQDT")) "RTN","DGQEUT2",80,0) ; "RTN","DGQEUT2",81,0) Q DGDAT "RTN","DGQEUT2",82,0) ; "RTN","DGQEUT2",83,0) ; "RTN","DGQEUT2",84,0) REQFLD(DGVIC,DGERR) ;required field check "RTN","DGQEUT2",85,0) ; This function is used to check for required fields in the VIC data "RTN","DGQEUT2",86,0) ; array. "RTN","DGQEUT2",87,0) ; "RTN","DGQEUT2",88,0) ; Input: "RTN","DGQEUT2",89,0) ; DGVIC - VIC data array (pass by reference) "RTN","DGQEUT2",90,0) ; "RTN","DGQEUT2",91,0) ; Output: "RTN","DGQEUT2",92,0) ; Function value - returns 1 on success, 0 on failure. "RTN","DGQEUT2",93,0) ; DGERR - error msg returned on failure "RTN","DGQEUT2",94,0) ; "RTN","DGQEUT2",95,0) N DGTYPE ;mailing address type "RTN","DGQEUT2",96,0) N DGSUB ;array subscript "RTN","DGQEUT2",97,0) ; "RTN","DGQEUT2",98,0) D ;quit DO block on first error "RTN","DGQEUT2",99,0) . ; "RTN","DGQEUT2",100,0) . ;check for required SSN "RTN","DGQEUT2",101,0) . I $G(DGVIC("SSN"))="" S DGERR="Unable to determine veteran's Social Security Number" "RTN","DGQEUT2",102,0) . Q:$D(DGERR) "RTN","DGQEUT2",103,0) . ; "RTN","DGQEUT2",104,0) . ;check for required DOB to include month and day "RTN","DGQEUT2",105,0) . I +$G(DGVIC("DOB"))>0 D "RTN","DGQEUT2",106,0) . . I +$E(DGVIC("DOB"),1,2)<1!(+$E(DGVIC("DOB"),3,4)<1) S DGERR="Unable to determine veteran's complete Date of Birth" "RTN","DGQEUT2",107,0) . E S DGERR="Unable to determine veteran's Date of Birth" "RTN","DGQEUT2",108,0) . Q:$D(DGERR) "RTN","DGQEUT2",109,0) . ; "RTN","DGQEUT2",110,0) . ;check for required name components "RTN","DGQEUT2",111,0) . ;F DGSUB="NAME","LAST","FIRST" D Q:$D(DGERR) "RTN","DGQEUT2",112,0) . ; DG*5.3*641 - do not check on first name "RTN","DGQEUT2",113,0) . F DGSUB="NAME","LAST" D Q:$D(DGERR) "RTN","DGQEUT2",114,0) . . I $G(DGVIC(DGSUB))="" S DGERR="Unable to determine veteran's Name" "RTN","DGQEUT2",115,0) . Q:$D(DGERR) "RTN","DGQEUT2",116,0) . ; "RTN","DGQEUT2",117,0) . ;check for address selection type "RTN","DGQEUT2",118,0) . I '$G(DGVIC("ADRTYPE")) S DGERR="Unable to determine a mailing address" "RTN","DGQEUT2",119,0) . Q:$D(DGERR) "RTN","DGQEUT2",120,0) . ; "RTN","DGQEUT2",121,0) . ;check for required pt address components "RTN","DGQEUT2",122,0) . F DGSUB="STREET1","CITY","STATE","ZIP" D Q:$D(DGERR) "RTN","DGQEUT2",123,0) . . I $G(DGVIC(DGSUB))="" D "RTN","DGQEUT2",124,0) . . . S DGTYPE=$S(DGVIC("ADRTYPE")=1:"permanent",DGVIC("ADRTYPE")=2:"temporary",DGVIC("ADRTYPE")=3:"confidential",1:"facility") "RTN","DGQEUT2",125,0) . . . S DGERR="Unable to determine the "_DGSUB_" field of the "_DGTYPE_" mailing address" "RTN","DGQEUT2",126,0) . Q:$D(DGERR) "RTN","DGQEUT2",127,0) . ; "RTN","DGQEUT2",128,0) . ;check for required VIC eligibility factors "RTN","DGQEUT2",129,0) . F DGSUB="SC" D Q:$D(DGERR) "RTN","DGQEUT2",130,0) . . I $G(DGVIC(DGSUB))="" S DGERR="Unable to determine veteran's Service Connected Indicator" "RTN","DGQEUT2",131,0) . Q:$D(DGERR) "RTN","DGQEUT2",132,0) . ; "RTN","DGQEUT2",133,0) . ;check for required facility data elements "RTN","DGQEUT2",134,0) . F DGSUB="FACNUM","FACNAME","VISN" D Q:$D(DGERR) "RTN","DGQEUT2",135,0) . . I $G(DGVIC(DGSUB))="" S DGERR="Unable to determine a source facility" "RTN","DGQEUT2",136,0) ; "RTN","DGQEUT2",137,0) Q $S($D(DGERR):0,1:1) "RTN","DGQEUT2",138,0) ; "RTN","DGQEUT2",139,0) ; "RTN","DGQEUT2",140,0) HOLD(DGVIC,DGMSG) ;check for pending ICN and/or Enrollment Status "RTN","DGQEUT2",141,0) ; This function checks for a pending ICN and/or Enrollment Status and "RTN","DGQEUT2",142,0) ; builds the appropriate message text when a pending condition exists. "RTN","DGQEUT2",143,0) ; "RTN","DGQEUT2",144,0) ; Input: "RTN","DGQEUT2",145,0) ; DGVIC - VIC data array, pass by reference "RTN","DGQEUT2",146,0) ; Array subscripts are: "RTN","DGQEUT2",147,0) ; "ICN" - integration control number "RTN","DGQEUT2",148,0) ; Note: Must be in format returned by $$GETICN^DGQEDEMO "RTN","DGQEUT2",149,0) ; "ENRSTAT" - enrollment status "RTN","DGQEUT2",150,0) ; Note: Must be in format returned by $$STATUS^DGENA "RTN","DGQEUT2",151,0) ; "RTN","DGQEUT2",152,0) ; Output: "RTN","DGQEUT2",153,0) ; Function value - set of codes if pending data, 0 if no pending data "RTN","DGQEUT2",154,0) ; 1:National ICN missing "RTN","DGQEUT2",155,0) ; 2:Enrollment Status missing "RTN","DGQEUT2",156,0) ; 3:Both National ICN & Enrollment Status missing "RTN","DGQEUT2",157,0) ; DGMSG - message text containing what data is missing, pass by "RTN","DGQEUT2",158,0) ; reference "RTN","DGQEUT2",159,0) ; "RTN","DGQEUT2",160,0) N DGENRST ;validated enrollment status value "RTN","DGQEUT2",161,0) N DGRSLT ;function value "RTN","DGQEUT2",162,0) ; "RTN","DGQEUT2",163,0) S DGRSLT=0 "RTN","DGQEUT2",164,0) S DGENRST=+$G(DGVIC("ENRSTAT")) "RTN","DGQEUT2",165,0) ; "RTN","DGQEUT2",166,0) I '+$G(DGVIC("ICN")) D "RTN","DGQEUT2",167,0) . S DGRSLT=DGRSLT+1 "RTN","DGQEUT2",168,0) ; "RTN","DGQEUT2",169,0) I 'DGENRST!(DGENRST=1)!(DGENRST=15)!(DGENRST=16)!(DGENRST=17)!(DGENRST=18) D "RTN","DGQEUT2",170,0) . S DGRSLT=DGRSLT+2 "RTN","DGQEUT2",171,0) ; "RTN","DGQEUT2",172,0) I DGRSLT D "RTN","DGQEUT2",173,0) . S DGMSG="Veteran has a pending " "RTN","DGQEUT2",174,0) . S DGMSG=DGMSG_$S(DGRSLT=1:"National ICN",DGRSLT=2:"Enrollment Status",DGRSLT=3:"National ICN and Enrollment Status",1:"") "RTN","DGQEUT2",175,0) ; "RTN","DGQEUT2",176,0) Q DGRSLT "RTN","DGQEUT2",177,0) ; "RTN","DGQEUT2",178,0) ; "RTN","DGQEUT2",179,0) VICELIG(DGELG) ;is applicant eligible for a Veteran ID Card? "RTN","DGQEUT2",180,0) ; This function determines if an applicant is eligible for a Veteran "RTN","DGQEUT2",181,0) ; Identification Card (VIC). "RTN","DGQEUT2",182,0) ; "RTN","DGQEUT2",183,0) ; Input: "RTN","DGQEUT2",184,0) ; DGELG - eligibility data object array "RTN","DGQEUT2",185,0) ; "RTN","DGQEUT2",186,0) ; Output: "RTN","DGQEUT2",187,0) ; Function Value - returns 1 if the applicant is eligible for VIC, "RTN","DGQEUT2",188,0) ; 0 if not eligible "RTN","DGQEUT2",189,0) ; "RTN","DGQEUT2",190,0) N DGRSLT ;function result "RTN","DGQEUT2",191,0) ; "RTN","DGQEUT2",192,0) ;set default, not eligible "RTN","DGQEUT2",193,0) S DGRSLT=0 "RTN","DGQEUT2",194,0) ; "RTN","DGQEUT2",195,0) D ;apply VIC eligibilty rules "RTN","DGQEUT2",196,0) . I (DGELG("ENRSTAT")=2)!(DGELG("ENRSTAT")=21) S DGRSLT=1 Q "RTN","DGQEUT2",197,0) . ; "RTN","DGQEUT2",198,0) . I (DGELG("ENRSTAT")=7)!(DGELG("ENRSTAT")=19)!(DGELG("ENRSTAT")=20) D Q:DGRSLT "RTN","DGQEUT2",199,0) . . Q:DGELG("ELIGSTAT")'="V" "RTN","DGQEUT2",200,0) . . I DGELG("MST")="Y" S DGRSLT=1 Q "RTN","DGQEUT2",201,0) . . I DGELG("SC")=1 S DGRSLT=1 Q "RTN","DGQEUT2",202,0) . ; "RTN","DGQEUT2",203,0) . I (DGELG("ENRSTAT")=11)!(DGELG("ENRSTAT")=12)!(DGELG("ENRSTAT")=13)!(DGELG("ENRSTAT")=14)!(DGELG("ENRSTAT")=22) D Q:DGRSLT "RTN","DGQEUT2",204,0) . . Q:DGELG("ELIGSTAT")'="V" "RTN","DGQEUT2",205,0) . . I DGELG("COMBVET")=1 S DGRSLT=1 Q "RTN","DGQEUT2",206,0) . . I DGELG("SC")=1 S DGRSLT=1 Q "RTN","DGQEUT2",207,0) . . I DGELG("MST")="Y" S DGRSLT=1 Q "RTN","DGQEUT2",208,0) ; "RTN","DGQEUT2",209,0) Q DGRSLT "RTN","DGRPC") 0^6^B24653446 "RTN","DGRPC",1,0) DGRPC ;ALB/MRL/PJR/PHH/EG - CHECK CONSISTENCY OF PATIENT DATA ; 3/28/05 2:59pm "RTN","DGRPC",2,0) ;;5.3;Registration;**108,121,314,301,470,489,505,451,568,585,641**;Aug 13, 1993 "RTN","DGRPC",3,0) ; "RTN","DGRPC",4,0) ;linetags in routines correspond to IEN of file 38.6 "RTN","DGRPC",5,0) ; "RTN","DGRPC",6,0) ;variables: DGVT = 1 if VETERAN? = YES, 0 if NO "RTN","DGRPC",7,0) ; DGSC = 1 if SC? = YES, 0 if NO "RTN","DGRPC",8,0) ; DGCD = 0 node of file EC file (#8) "RTN","DGRPC",9,0) ; DGRPCOLD = old inconsistencies for pt (separated by ,s) "RTN","DGRPC",10,0) ; DGCHK = #s to check (separated by ,s) "RTN","DGRPC",11,0) ; DGLST = next # to check "RTN","DGRPC",12,0) ; DGER = inconsistencies found (separated by ,s) "RTN","DGRPC",13,0) ; DGNCK = 1 if missing key elig data...can't process further "RTN","DGRPC",14,0) ; "RTN","DGRPC",15,0) N ANYMSE,CONARR,CONCHK,CONERR,CONSPEC,LOC,I5,I6 "RTN","DGRPC",16,0) N MSECHK,MSESET,MSERR,MSDATERR,RANGE,RANSET "RTN","DGRPC",17,0) D ON I $S(('$D(DFN)#2):1,'$D(^DPT(DFN,0)):1,DGER:1,1:0) G KVAR^DGRPCE:DGER "RTN","DGRPC",18,0) EN S:'$D(DGEDCN)#2 DGEDCN=0 I DGEDCN W !!,"Checking data for consistency..." "RTN","DGRPC",19,0) D START:DGEDCN "RTN","DGRPC",20,0) F I=0,.13,.141,.22,.24,.3,.31,.311,.32,.321,.322,.33,.35,.36,.362,.38,.39,.52,.53,"TYPE","VET" S DGP(I)=$G(^DPT(DFN,I)) "RTN","DGRPC",21,0) ;get old inconsistencies "RTN","DGRPC",22,0) S DGRPCOLD="," I $D(^DGIN(38.5,DFN)) F I=0:0 S I=$O(^DGIN(38.5,DFN,"I",I)) Q:'I S DGRPCOLD=DGRPCOLD_I_"," "RTN","DGRPC",23,0) ;find consistencies to check/not check "RTN","DGRPC",24,0) S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,'$P(^(0),"^",5):1,1:0),I'=99 S DGCHK=DGCHK_I_"," "RTN","DGRPC",25,0) S DGVT=$S(DGP("VET")="Y":1,1:0),DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0),DGCD=$S($D(^DIC(8,+DGP(.36),0)):^(0),1:""),(DGCT,DGER,DGNCK)="" I 'DGVT,$D(^DG(391,+DGP("TYPE"),0)),$P(^(0),"^",2) S DGVT=2 "RTN","DGRPC",26,0) S DGLST=+$P(DGCHK,",",2) G @DGLST "RTN","DGRPC",27,0) 1 S DGD=$P(DGP(0),"^",1) I DGD?1L.E!(DGD?.E1L.E)!(DGD="") S X=1 D COMB,NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",28,0) S I1=0 F I=1:1:$L(DGD) Q:I1 S J=$E(DGD,I) I J?1NP,$A(J)>32,J'=",",J'="-",J'=".",J'="'" S I1=1 "RTN","DGRPC",29,0) I I1 S X=1 D COMB "RTN","DGRPC",30,0) D NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",31,0) 2 S I1=0 F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I!(I1) I $P(^(I,0),"^",1)'?1A.E S I1=1 "RTN","DGRPC",32,0) I I1 S X=2 D COMB "RTN","DGRPC",33,0) D NEXT I +DGLST>7!('DGLST) G @DGLST "RTN","DGRPC",34,0) 3 ; "RTN","DGRPC",35,0) 4 ; "RTN","DGRPC",36,0) 5 ; "RTN","DGRPC",37,0) 6 ; "RTN","DGRPC",38,0) 7 F I=2,3,5,8,9 I $P(DGP(0),"^",I)="" S X=$S(I=2:3,I=3:4,I=5:5,I=8:6,1:7) D COMB:DGCHK[(","_X_",") "RTN","DGRPC",39,0) S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST "RTN","DGRPC",40,0) 8 S I1=0,DGD=$G(^DPT(DFN,.11)) F I=1,4,5,6,7 Q:I1 I $P(DGD,"^",I)="" S I1=1 "RTN","DGRPC",41,0) I I1 S X=8 D COMB "RTN","DGRPC",42,0) D NEXT I +DGLST'=9 G @DGLST "RTN","DGRPC",43,0) 9 I DGP("VET")="" S X=9,DGNCK=1 D COMB "RTN","DGRPC",44,0) D NEXT I +DGLST'=10 G @DGLST "RTN","DGRPC",45,0) 10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB "RTN","DGRPC",46,0) D NEXT I +DGLST'=11 G @DGLST "RTN","DGRPC",47,0) 11 I 'DGVT,DGSC S X=11 D COMB "RTN","DGRPC",48,0) D NEXT I +DGLST'=12 G @DGLST "RTN","DGRPC",49,0) 12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB "RTN","DGRPC",50,0) D NEXT I +DGLST'=13 G @DGLST "RTN","DGRPC",51,0) 13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB "RTN","DGRPC",52,0) D NEXT I +DGLST'=14 G @DGLST "RTN","DGRPC",53,0) 14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB "RTN","DGRPC",54,0) ; "RTN","DGRPC",55,0) ;Check Patient Eligibilities multiple if Primary Elig Code defined "RTN","DGRPC",56,0) I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301 "RTN","DGRPC",57,0) ; "RTN","DGRPC",58,0) D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",59,0) 15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB "RTN","DGRPC",60,0) D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",61,0) 16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB "RTN","DGRPC",62,0) D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",63,0) 17 K DGDATE,DGTIME "RTN","DGRPC",64,0) N SDARRAY,SDCLIEN,SDDATE "RTN","DGRPC",65,0) S I1=0,DGD=DT "RTN","DGRPC",66,0) S SDARRAY("FLDS")=3 "RTN","DGRPC",67,0) S SDARRAY(4)=DFN "RTN","DGRPC",68,0) I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D "RTN","DGRPC",69,0) .;if there is data hanging from the 101 subscript, "RTN","DGRPC",70,0) .;then this is a valid appointment "RTN","DGRPC",71,0) .;otherwise it is an error eg 01/21/2005 "RTN","DGRPC",72,0) .I $D(^TMP($J,"SDAMA301",101))=1 Q "RTN","DGRPC",73,0) .S SDCLIEN=0 "RTN","DGRPC",74,0) .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(I1) D "RTN","DGRPC",75,0) ..S SDDATE=0 "RTN","DGRPC",76,0) ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(I1) D "RTN","DGRPC",77,0) ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";") "RTN","DGRPC",78,0) ...I X=""!(X="I") S I1=1 "RTN","DGRPC",79,0) K ^TMP($J,"SDAMA301") "RTN","DGRPC",80,0) I I1 S X=17 D COMB "RTN","DGRPC",81,0) ; "RTN","DGRPC",82,0) END ; end of routine...find next check to execute (or goto end) "RTN","DGRPC",83,0) S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST "RTN","DGRPC",84,0) ; "RTN","DGRPC",85,0) COMB ;record inconsistency "RTN","DGRPC",86,0) S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q "RTN","DGRPC",87,0) Q "RTN","DGRPC",88,0) ; "RTN","DGRPC",89,0) NEXT ; find the next consistency check to check (goto end if can't process further) "RTN","DGRPC",90,0) S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q "RTN","DGRPC",91,0) I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35," G NEXT "RTN","DGRPC",92,0) S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,+DGLST<79:2,1:3) "RTN","DGRPC",93,0) Q "RTN","DGRPC",94,0) ; "RTN","DGRPC",95,0) PAT ;check inconsistencies for a selected patient "RTN","DGRPC",96,0) D ON G KVAR^DGRPCE:DGER W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Check consistency for which PATIENT: " D ^DIC K DIC G KVAR^DGRPCE:Y'>0 S DFN=+Y,DGEDCN=1 D DGRPC G PAT "RTN","DGRPC",97,0) ; "RTN","DGRPC",98,0) START ;record start time for checker "RTN","DGRPC",99,0) S DGSTART=$H Q "RTN","DGRPC",100,0) ; "RTN","DGRPC",101,0) TIME ;record end time for checker "RTN","DGRPC",102,0) Q:'$D(DGSTART)#2 S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2) "RTN","DGRPC",103,0) I +DGSTART=+DGEND S DGTIME=X1-X "RTN","DGRPC",104,0) E S DGTIME=(5184000-X)+X1 "RTN","DGRPC",105,0) I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ "RTN","DGRPC",106,0) W !!,"===> ",$S(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$S(DGCT=1:"y",1:"ies")," ",$S('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$S(DGTIME=1:"",1:"s"),"..." H 1 "RTN","DGRPC",107,0) TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q "RTN","DGRPC",108,0) ; "RTN","DGRPC",109,0) ON ;check if checker is on "RTN","DGRPC",110,0) S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1 "RTN","DGRPC",111,0) S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q "RTN","DPTLK1") 0^5^B39062808 "RTN","DPTLK1",1,0) DPTLK1 ;ALB/RMO - MAS Patient Look-up Check Cross-References ; 4/27/05 1:16pm "RTN","DPTLK1",2,0) ;;5.3;Registration;**32,50,197,249,317,391,244,532,574,620,641**;Aug 13, 1993 "RTN","DPTLK1",3,0) FIND ;Cross reference patient lookup "RTN","DPTLK1",4,0) ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented "RTN","DPTLK1",5,0) ; by patch DG*5.3*244 "RTN","DPTLK1",6,0) ; "RTN","DPTLK1",7,0) N DDCOMA,DPTXOLD,DPTOUT,DPTOVAL,DGLASTLK "RTN","DPTLK1",8,0) S DGLASTLK=1 "RTN","DPTLK1",9,0) S (DPTXOLD,DPTX)=$$UCASE(DPTX) "RTN","DPTLK1",10,0) I DPTX?1A.E1","1.A.E S DPTXOLD=DPTX,DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$L($P(DPTX,",",2))_")="""_$TR($P(DPTX,",",2),"""")_"""",DPTX=$P(DPTX,",") "RTN","DPTLK1",11,0) K DPTREFS S DPTREFS=$S(DIC(0)'["M":"B,NOP",DPTX?1A1N.N:$S($L(DPTX)<6:"BS5,CN,RM",1:"CN,RM"),DPTX?4N!(DPTX?4N1A):"BS,SSN,CN,RM",DPTX?9N.E:"SSN,CN,RM",1:"") "RTN","DPTLK1",12,0) S:DPTREFS="" DPTREFS=$S(DPTX?1N.N:$S($L(DPTX)<5:"CN,RM,BS,SSN",1:"CN,RM,SSN"),DPTX?1N.E:"CN,RM",1:"B,NOP,CN,RM") S:$D(DPTIX) DPTREFS=DPTIX_","_DPTREFS "RTN","DPTLK1",13,0) S DPTBEG=1,(DPTDFN,DPTNUM,DPTOUT)=0 "RTN","DPTLK1",14,0) F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=""!(DPTDFN) D Q:DPTDFN!DPTOUT "RTN","DPTLK1",15,0) .S DPTVAL=DPTX "RTN","DPTLK1",16,0) .I DPTREF="NOP",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^XLFNAME7(DPTVAL,2,30,1,0,,1) Q:'$L(DPTVAL) "RTN","DPTLK1",17,0) .D LOOK(DPTVAL) "RTN","DPTLK1",18,0) .I DPTREF="B",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^XLFNAME7(DPTX,2,30,1,0,,1) D:DPTVAL'=DPTX LOOK(DPTVAL) "RTN","DPTLK1",19,0) .Q "RTN","DPTLK1",20,0) SET I 'DPTDFN S:DPTCNT=1&($D(DPTIFNS(DPTCNT))) DPTDFN=+DPTIFNS(DPTCNT) S DPT("NOPRT^")="" D PRTDPT:'DPTDFN&(DPTCNT>DPTNUM)&(DIC(0)["E") K DPT("NOPRT^") I 'DPTDFN,$D(DPTSEL),DPTSEL="" S DPTX="",DPTDFN=-1 "RTN","DPTLK1",21,0) I DPTDFN'>0,$L($G(DPTXOLD)) I DPTX=$P(DPTXOLD,",") S DPTX=DPTXOLD "RTN","DPTLK1",22,0) I DPTDFN>0,$D(DPTXOLD) S DPTX=DPTXOLD "RTN","DPTLK1",23,0) ; one last stab at lookup - DG*641 "RTN","DPTLK1",24,0) I '$G(DPTCNT),DPTX[",",DGLASTLK=1,'$G(DPTNOFZY) D "RTN","DPTLK1",25,0) .S DPTX=$$FORMAT^XLFNAME7(DPTX,2,30,1) "RTN","DPTLK1",26,0) .S DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$L($P(DPTX,",",2))_")="""_$TR($P(DPTX,",",2),"""")_"""" "RTN","DPTLK1",27,0) .S DPTX=$P(DPTX,",") "RTN","DPTLK1",28,0) .S DGLASTLK=0 "RTN","DPTLK1",29,0) .S DPTREFS="B,NOP,CN,RM" "RTN","DPTLK1",30,0) .F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=""!(DPTDFN) D Q:DPTDFN!DPTOUT "RTN","DPTLK1",31,0) ..S DPTVAL=DPTX "RTN","DPTLK1",32,0) ..D LOOK(DPTVAL) "RTN","DPTLK1",33,0) I DGLASTLK=0,$G(DPTCNT) S DGLASTLK=1 G SET "RTN","DPTLK1",34,0) I DGLASTLK=0,'$G(DPTCNT),$L($G(DPTXOLD)) I DPTX=$P(DPTXOLD,",") S DPTX=DPTXOLD "RTN","DPTLK1",35,0) ; end of DG*641 change "RTN","DPTLK1",36,0) ; "RTN","DPTLK1",37,0) Q K DPTBEG,DPTIFN,DPTIFNS,DPTLP,DPTLP1,DPTNUM,DPTREF,DPTREFS,DPTVAL "RTN","DPTLK1",38,0) K DPTOVAL,DPTOUT,DPTXOLD,^TMP("DPTLK",$J) "RTN","DPTLK1",39,0) Q "RTN","DPTLK1",40,0) ; "RTN","DPTLK1",41,0) LOOK(DPTVAL) ;Look for x-ref matches "RTN","DPTLK1",42,0) ;Input: DPTVAL=lookup seed value "RTN","DPTLK1",43,0) I $L(DPTVAL),$D(^DPT(DPTREF,DPTVAL)) D CHKIFN Q:DPTDFN!DPTOUT "RTN","DPTLK1",44,0) I $L(DPTVAL),'($D(^DPT(DPTREF,DPTVAL))&(DIC(0)["O"))&(DIC(0)'["X") D CHKVAL "RTN","DPTLK1",45,0) Q "RTN","DPTLK1",46,0) ; "RTN","DPTLK1",47,0) CHKVAL S DPTOVAL=DPTVAL "RTN","DPTLK1",48,0) N DPTSEED S DPTSEED=DPTVAL "RTN","DPTLK1",49,0) I DPTREF="SSN",(DPTVAL?9N1"p") D Q "RTN","DPTLK1",50,0) .S DPTVAL=$E(DPTVAL,1,9)_"P" D CHKIFN "RTN","DPTLK1",51,0) .Q "RTN","DPTLK1",52,0) I DPTREF="SSN",(DPTVAL?2.9N) D Q "RTN","DPTLK1",53,0) .S DPTVAL=$E(DPTVAL_"0000000",1,9) "RTN","DPTLK1",54,0) .D CV1(DPTVAL),CHKIFN "RTN","DPTLK1",55,0) .S DPTVAL=DPTVAL_"P" D CV1(DPTVAL),CHKIFN "RTN","DPTLK1",56,0) .Q "RTN","DPTLK1",57,0) D CV1(DPTVAL) "RTN","DPTLK1",58,0) I DPTREF="CN"!(DPTREF="RM"),DPTVAL'["E",DPTVAL=+DPTVAL,'$D(^DPT(DPTREF,DPTVAL)) D Q "RTN","DPTLK1",59,0) .S DPTVAL=$O(^DPT(DPTREF,DPTVAL_" "),-1) "RTN","DPTLK1",60,0) .D CV1(DPTVAL) "RTN","DPTLK1",61,0) .Q "RTN","DPTLK1",62,0) Q "RTN","DPTLK1",63,0) ; "RTN","DPTLK1",64,0) CV1(DPTVAL) ;Look for input value matches "RTN","DPTLK1",65,0) I $L(DPTVAL) F DPTLP1=0:0 S DPTVAL=$O(^DPT(DPTREF,DPTVAL)) Q:DPTVAL=""!(DPTDFN)!($P(DPTVAL,DPTSEED)'="") D CHKIFN "RTN","DPTLK1",66,0) Q "RTN","DPTLK1",67,0) ; "RTN","DPTLK1",68,0) CHKIFN F DPTIFN=0:0 S DPTIFN=$O(^DPT(DPTREF,DPTVAL,DPTIFN)) Q:'DPTIFN!(DPTDFN)!DPTOUT S Y=DPTIFN D SETDPT I $SDPTLMAX D Q "RTN","DPTLK1",83,0) ..S @DPTLARR@(DPTCNT)="ADDITIONAL MATCHES FOUND BUT NOT RETURNED" "RTN","DPTLK1",84,0) ..S DPTOUT=1 "RTN","DPTLK1",85,0) ..Q "RTN","DPTLK1",86,0) .S @DPTLARR@(DPTCNT)=DPTIFNS(DPTCNT)_U_$$SSN(Y)_U_$$DOB(Y) "RTN","DPTLK1",87,0) .Q "RTN","DPTLK1",88,0) I '(DPTCNT#5),DIC(0)["E" D PRTDPT "RTN","DPTLK1",89,0) Q "RTN","DPTLK1",90,0) ; "RTN","DPTLK1",91,0) PRTDPT I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY S X=0 X ^%ZOSF("RM") "RTN","DPTLK1",92,0) N DPTP1,DPTP2 "RTN","DPTLK1",93,0) F DPTNUM=DPTNUM+1:1:DPTCNT Q:DPTOUT S DPTIFN=+DPTIFNS(DPTNUM) D "RTN","DPTLK1",94,0) .W:'$D(DDS) ! "RTN","DPTLK1",95,0) .S DPTP2=$P(DPTIFNS(DPTNUM),U,3) "RTN","DPTLK1",96,0) .S DPTP1=$P(DPTIFNS(DPTNUM),U,2) "RTN","DPTLK1",97,0) .W ?3,DPTNUM,?$X+(4-$L(DPTNUM)) "RTN","DPTLK1",98,0) .; write the xref value "RTN","DPTLK1",99,0) .W DPTP2_" " "RTN","DPTLK1",100,0) .; write patient name if diff than xref value "RTN","DPTLK1",101,0) .I DPTP1'=DPTP2 W DPTP1 "RTN","DPTLK1",102,0) .S Y=DPTIFN X:$D(^DPT(DPTIFN,0)) "N DDS X DIC(""W"")" I $D(DDS) S DY=DY+1,DX=0 X DDXY S $X=0 "RTN","DPTLK1",103,0) I '$D(DPT("NOPRT^")) W:'$D(DDS) ! W "ENTER '^' TO STOP, OR " "RTN","DPTLK1",104,0) W:'$D(DDS) ! W "CHOOSE ",DPTBEG,"-",DPTNUM,": " R X:DTIME S DPTSEL=X D Q:DPTSEL=""!$D(DTOUT)!$D(DUOUT) "RTN","DPTLK1",105,0) .S:'$T DPTSEL=$S($D(DPTOVAL):DPTOVAL,$D(DPTVAL):DPTVAL,$D(DPTX):DPTX,$D(DPTXOLD):DPTXOLD,1:""),(DPTOUT,DTOUT)=1 "RTN","DPTLK1",106,0) .S:X="^" (DPTOUT,DUOUT)=1 "RTN","DPTLK1",107,0) S DPTDFN=$S(DPTSEL'?.ANP!($L(DPTSEL)>30):-1,'$D(DPTIFNS(DPTSEL)):-1,$D(DPTS(+DPTIFNS(DPTSEL))):+DPTIFNS(DPTSEL),1:-1),DPTX=$S(DPTDFN<0:DPTSEL,1:DPTX) "RTN","DPTLK1",108,0) S:DPTDFN=-1 DPTXOLD=DPTSEL "RTN","DPTLK1",109,0) Q "RTN","DPTLK1",110,0) ; "RTN","DPTLK1",111,0) LIST(DPTX,DPTLMAX,DPTLARR) ;Silent lookup list "RTN","DPTLK1",112,0) ;Input: DPTX=lookup value (name, SSN, room, ward, DFN or "RTN","DPTLK1",113,0) ; "space_return"). "RTN","DPTLK1",114,0) ; DPTLMAX=maximum number of matches to return (optional), this "RTN","DPTLK1",115,0) ; parameter has no effect if DFN or "space_return" "RTN","DPTLK1",116,0) ; lookup methods are used. "RTN","DPTLK1",117,0) ; DPTLARR=name of array to return list of matches, this should "RTN","DPTLK1",118,0) ; be a global if DPTLMAX is a large value or unspecified "RTN","DPTLK1",119,0) ; This array is returned in the format: "RTN","DPTLK1",120,0) ; @DPTLARR@(n)=DFN^patient_name^xref_lookup_match_value^ "RTN","DPTLK1",121,0) ; SSN^Date_of_Birth "RTN","DPTLK1",122,0) ; If more matches exist than the maximum to be returned "RTN","DPTLK1",123,0) ; as specified by DPTLMAX, the @DPTLARR@(DPTLMAX+1) node "RTN","DPTLK1",124,0) ; will be defined = "ADDITIONAL MATCHES FOUND BUT NOT "RTN","DPTLK1",125,0) ; RETURNED". "RTN","DPTLK1",126,0) ; The calling program has the responsibility to kill "RTN","DPTLK1",127,0) ; @DPTLARR prior to calling this entry point. "RTN","DPTLK1",128,0) ;Output: number of matches and array named by DPTLARR. "RTN","DPTLK1",129,0) ; "RTN","DPTLK1",130,0) N X,Y,DPTCNT,DIC,DPTSZ,DPTDFN,DPTIFNS,DPTS "RTN","DPTLK1",131,0) S DPTCNT=0,DIC(0)="M",DPTSZ=1000 S:$G(DPTLMAX)<1 DPTLMAX=0 "RTN","DPTLK1",132,0) ;Check for "space_return" or DFN lookup "RTN","DPTLK1",133,0) I DPTX=" "!($E(DPTX)="`") D Q DPTCNT "RTN","DPTLK1",134,0) .I DPTX=" " S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) "RTN","DPTLK1",135,0) .I $E(DPTX)="`" S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1) "RTN","DPTLK1",136,0) .Q:Y<1 Q:'$D(^DPT(Y,0)) D SETDPT S DPTCNT=1 "RTN","DPTLK1",137,0) .Q "RTN","DPTLK1",138,0) D FIND "RTN","DPTLK1",139,0) Q $S(DPTLMAX&(DPTCNT>DPTLMAX):DPTLMAX,1:DPTCNT) "RTN","DPTLK1",140,0) ; "RTN","DPTLK1",141,0) UCASE(DGX) ;Uppercase lookup value "RTN","DPTLK1",142,0) ;Input: DGX=lookup value "RTN","DPTLK1",143,0) ;Output: transformed DGX "RTN","DPTLK1",144,0) N DGI,DGY,DGZ S DGZ=DGX,DGX="" "RTN","DPTLK1",145,0) F DGI=1:1:$L(DGZ) S DGY=$E(DGZ,DGI) D "RTN","DPTLK1",146,0) .S:DGY?1L DGY=$C($A(DGY)-32) "RTN","DPTLK1",147,0) .S DGX=DGX_DGY "RTN","DPTLK1",148,0) Q DGX "RTN","DPTLK1",149,0) ; "RTN","DPTLK1",150,0) SSN(DFN) ;do not show ssn identifier for patient "RTN","DPTLK1",151,0) ; input DFN = ien in file #2 [required] "RTN","DPTLK1",152,0) ; output SSN = nnnnnnnnn "RTN","DPTLK1",153,0) ; "RTN","DPTLK1",154,0) N SSN "RTN","DPTLK1",155,0) S SSN="",DFN=+DFN "RTN","DPTLK1",156,0) I DFN>0 D "RTN","DPTLK1",157,0) .I $$SCREEN(DFN) S SSN="*SENSITIVE*" Q "RTN","DPTLK1",158,0) .S SSN=$P($G(^DPT(DFN,0)),U,9) "RTN","DPTLK1",159,0) Q SSN "RTN","DPTLK1",160,0) ; "RTN","DPTLK1",161,0) DOB(DFN,DGYR) ;do not show dob identifier for patient "RTN","DPTLK1",162,0) ; input DFN = ien in file #2 [required] "RTN","DPTLK1",163,0) ; DGYR = 0/1 [optional] "RTN","DPTLK1",164,0) ; where 0 returns 4-digit year (default) "RTN","DPTLK1",165,0) ; 1 returns 2-digit year "RTN","DPTLK1",166,0) ; 2 returns File manager date "RTN","DPTLK1",167,0) ; output DOB = mm/dd/yyyy (default) "RTN","DPTLK1",168,0) ; = mm/dd/yy, if DGYR=1 "RTN","DPTLK1",169,0) ; = yyymmdd, if DGYR=2 "RTN","DPTLK1",170,0) N B,DOB,YEAR "RTN","DPTLK1",171,0) S DOB="",DFN=+DFN,DGYR=+$G(DGYR) "RTN","DPTLK1",172,0) I DFN>0 D "RTN","DPTLK1",173,0) .I $$SCREEN(DFN) S DOB="*SENSITIVE*" Q "RTN","DPTLK1",174,0) .S B=$P($G(^DPT(DFN,0)),U,3) "RTN","DPTLK1",175,0) .I DGYR'=2 D Q "RTN","DPTLK1",176,0) ..S YEAR=$S(DGYR=1:"2D",1:"5D") "RTN","DPTLK1",177,0) ..S DOB=$$FMTE^XLFDT(B,YEAR) "RTN","DPTLK1",178,0) .S DOB=B "RTN","DPTLK1",179,0) Q DOB "RTN","DPTLK1",180,0) ; "RTN","DPTLK1",181,0) SCREEN(DFN) ;Screening logic for SSN & DOB "RTN","DPTLK1",182,0) ;Input : DFN - Pointer to PATIENT file (#2) "RTN","DPTLK1",183,0) ;Output : 1 - Apply screen "RTN","DPTLK1",184,0) ; 0 - Don't apply screen "RTN","DPTLK1",185,0) ;Notes : Screen applied if patient is sensitive or an employee "RTN","DPTLK1",186,0) ; "RTN","DPTLK1",187,0) N DGTIME,DGT,DGA1,DG1,DGXFR0 "RTN","DPTLK1",188,0) ;Inpatient check - no longer used (kept for future reference) "RTN","DPTLK1",189,0) ;D H^DGUTL S DGT=DGTIME D ^DGPMSTAT I DG1 Q 0 "RTN","DPTLK1",190,0) ;Sensitive - screen "RTN","DPTLK1",191,0) I $P($G(^DGSL(38.1,DFN,0)),"^",2) Q 1 "RTN","DPTLK1",192,0) ;Employee - screen "RTN","DPTLK1",193,0) I $$EMPL^DGSEC4(DFN) Q 1 "RTN","DPTLK1",194,0) ;Don't screen "RTN","DPTLK1",195,0) Q 0 "VER") 8.0^22.0 "BLD",5988,6) ^SEQ #576 **END** **END**