Released DG*5.3*515 SEQ #449 Extracted from mail message **KIDS**:DG*5.3*515^ **INSTALL NAME** DG*5.3*515 "BLD",4251,0) DG*5.3*515^REGISTRATION^0^3030430^y "BLD",4251,1,0) ^^21^21^3030430^ "BLD",4251,1,1,0) Geographic Means Tests was introduced changing the naming conventions of "BLD",4251,1,2,0) Category A and Category C Means Tests. This patch will update the Gains "BLD",4251,1,3,0) and Losses (G&L) Sheet with modifications needed to conform to these "BLD",4251,1,4,0) changes in the display of Means Test status. "BLD",4251,1,5,0) "BLD",4251,1,6,0) Changes will include the following: "BLD",4251,1,7,0) ----------------------------------- "BLD",4251,1,8,0) "BLD",4251,1,9,0) 1. The legend diplayed when listing Means Test statuses for patients will "BLD",4251,1,10,0) replace Category 'A' Veteran with MT Copay Exempt; replace Category "BLD",4251,1,11,0) 'C' Veteran with MT Copay Required; add GMT Copay Required. "BLD",4251,1,12,0) "BLD",4251,1,13,0) 2. Patients with a Pending Adjudication Means Test status will display "BLD",4251,1,14,0) whether the pending adjudication is for MT Copay Required or GMT Copay "BLD",4251,1,15,0) Required, with the latter determination being displayed. "BLD",4251,1,16,0) "BLD",4251,1,17,0) 3. Title of 'Means Test Indicator's' under the parameters display will be "BLD",4251,1,18,0) replaced with 'Means Test Copay Applicability'. "BLD",4251,1,19,0) "BLD",4251,1,20,0) 4. Title of 'Means Test Display' under the parameters will be replaced "BLD",4251,1,21,0) with 'Means Test Copay Applicability Display'. "BLD",4251,4,0) ^9.64PA^^ "BLD",4251,"KRN",0) ^9.67PA^8989.52^19 "BLD",4251,"KRN",.4,0) .4 "BLD",4251,"KRN",.401,0) .401 "BLD",4251,"KRN",.402,0) .402 "BLD",4251,"KRN",.403,0) .403 "BLD",4251,"KRN",.5,0) .5 "BLD",4251,"KRN",.84,0) .84 "BLD",4251,"KRN",3.6,0) 3.6 "BLD",4251,"KRN",3.8,0) 3.8 "BLD",4251,"KRN",9.2,0) 9.2 "BLD",4251,"KRN",9.8,0) 9.8 "BLD",4251,"KRN",9.8,"NM",0) ^9.68A^4^4 "BLD",4251,"KRN",9.8,"NM",1,0) DGPMGL^^0^B23052249 "BLD",4251,"KRN",9.8,"NM",2,0) DGPMGL5^^0^B5724705 "BLD",4251,"KRN",9.8,"NM",3,0) DGPMGLG5^^0^B6461431 "BLD",4251,"KRN",9.8,"NM",4,0) DGPMGLP^^0^B21935096 "BLD",4251,"KRN",9.8,"NM","B","DGPMGL",1) "BLD",4251,"KRN",9.8,"NM","B","DGPMGL5",2) "BLD",4251,"KRN",9.8,"NM","B","DGPMGLG5",3) "BLD",4251,"KRN",9.8,"NM","B","DGPMGLP",4) "BLD",4251,"KRN",19,0) 19 "BLD",4251,"KRN",19,"NM",0) ^9.68A^^ "BLD",4251,"KRN",19.1,0) 19.1 "BLD",4251,"KRN",101,0) 101 "BLD",4251,"KRN",409.61,0) 409.61 "BLD",4251,"KRN",771,0) 771 "BLD",4251,"KRN",870,0) 870 "BLD",4251,"KRN",8989.51,0) 8989.51 "BLD",4251,"KRN",8989.52,0) 8989.52 "BLD",4251,"KRN",8994,0) 8994 "BLD",4251,"KRN","B",.4,.4) "BLD",4251,"KRN","B",.401,.401) "BLD",4251,"KRN","B",.402,.402) "BLD",4251,"KRN","B",.403,.403) "BLD",4251,"KRN","B",.5,.5) "BLD",4251,"KRN","B",.84,.84) "BLD",4251,"KRN","B",3.6,3.6) "BLD",4251,"KRN","B",3.8,3.8) "BLD",4251,"KRN","B",9.2,9.2) "BLD",4251,"KRN","B",9.8,9.8) "BLD",4251,"KRN","B",19,19) "BLD",4251,"KRN","B",19.1,19.1) "BLD",4251,"KRN","B",101,101) "BLD",4251,"KRN","B",409.61,409.61) "BLD",4251,"KRN","B",771,771) "BLD",4251,"KRN","B",870,870) "BLD",4251,"KRN","B",8989.51,8989.51) "BLD",4251,"KRN","B",8989.52,8989.52) "BLD",4251,"KRN","B",8994,8994) "BLD",4251,"QUES",0) ^9.62^^ "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) 515^3030430^123456825 "PKG",5,22,1,"PAH",1,1,0) ^^21^21^3030430 "PKG",5,22,1,"PAH",1,1,1,0) Geographic Means Tests was introduced changing the naming conventions of "PKG",5,22,1,"PAH",1,1,2,0) Category A and Category C Means Tests. This patch will update the Gains "PKG",5,22,1,"PAH",1,1,3,0) and Losses (G&L) Sheet with modifications needed to conform to these "PKG",5,22,1,"PAH",1,1,4,0) changes in the display of Means Test status. "PKG",5,22,1,"PAH",1,1,5,0) "PKG",5,22,1,"PAH",1,1,6,0) Changes will include the following: "PKG",5,22,1,"PAH",1,1,7,0) ----------------------------------- "PKG",5,22,1,"PAH",1,1,8,0) "PKG",5,22,1,"PAH",1,1,9,0) 1. The legend diplayed when listing Means Test statuses for patients will "PKG",5,22,1,"PAH",1,1,10,0) replace Category 'A' Veteran with MT Copay Exempt; replace Category "PKG",5,22,1,"PAH",1,1,11,0) 'C' Veteran with MT Copay Required; add GMT Copay Required. "PKG",5,22,1,"PAH",1,1,12,0) "PKG",5,22,1,"PAH",1,1,13,0) 2. Patients with a Pending Adjudication Means Test status will display "PKG",5,22,1,"PAH",1,1,14,0) whether the pending adjudication is for MT Copay Required or GMT Copay "PKG",5,22,1,"PAH",1,1,15,0) Required, with the latter determination being displayed. "PKG",5,22,1,"PAH",1,1,16,0) "PKG",5,22,1,"PAH",1,1,17,0) 3. Title of 'Means Test Indicator's' under the parameters display will be "PKG",5,22,1,"PAH",1,1,18,0) replaced with 'Means Test Copay Applicability'. "PKG",5,22,1,"PAH",1,1,19,0) "PKG",5,22,1,"PAH",1,1,20,0) 4. Title of 'Means Test Display' under the parameters will be replaced "PKG",5,22,1,"PAH",1,1,21,0) with 'Means Test Copay Applicability Display'. "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") 4 "RTN","DGPMGL") 0^1^B23052249 "RTN","DGPMGL",1,0) DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 29 APR 2003 "RTN","DGPMGL",2,0) ;;5.3;Registration;**85,515**;Aug 13, 1993 "RTN","DGPMGL",3,0) ; "RTN","DGPMGL",4,0) W !!,"<<>>",! "RTN","DGPMGL",5,0) A D DT^DICRW S U="^" D NOW^%DTC S NOW=% D LO^DGUTL "RTN","DGPMGL",6,0) D PCHK G ERR:E D PAR,GLR G ERR:E D RCR1 G:%=2 Q D WD G ERR:E D LAST G ERR:E D Q1 "RTN","DGPMGL",7,0) G A^DGPMGL1 "RTN","DGPMGL",8,0) ; "RTN","DGPMGL",9,0) PCHK ; Parameter Check "RTN","DGPMGL",10,0) D DAT S E=0 "RTN","DGPMGL",11,0) I 'DGPM("G") W !!,$S('$D(^DG(43,1,0)):"ADT SYSTEM",1:"G&L")," HASN'T BEEN INITIALIZED!!" S E=1 Q "RTN","DGPMGL",12,0) ; modified re FORUM [#16205729] to exclude 5. "RTN","DGPMGL",13,0) F I=2,3,4,6:1:9 S C=(.01*I) I $P(DGPM("G"),"^",I)']"" W !,"'",$S($D(^DD(43,1000_C,0)):$P(^(0),"^",1),1:"UNKNOWN"),"' PARAMETER NOT DEFINED!!" S E=1 Q "RTN","DGPMGL",14,0) Q "RTN","DGPMGL",15,0) ; "RTN","DGPMGL",16,0) PAR ; -- display params "RTN","DGPMGL",17,0) S L="",$P(L,".",50)="",Y=+DGPM("G") X ^DD("DD") "RTN","DGPMGL",18,0) W !,$E("Earliest Date for G&L"_L,1,58),Y "RTN","DGPMGL",19,0) S Y=$P(DGPM("G"),"^",11) X ^DD("DD") "RTN","DGPMGL",20,0) W !,$E("Earliest Date for Treating Specialty Report"_L,1,58),Y I Y']"" W "NOT DEFINED" "RTN","DGPMGL",21,0) S Y=$S($P(DGPM("G"),"^",7)']"":+DGPM("G"),$P(DGPM("G"),"^",7)<+DGPM("G"):+DGPM("G"),1:$P(DGPM("G"),"^",7)) X ^DD("DD") "RTN","DGPMGL",22,0) W !,$E("Earliest Date to Recalculate"_L,1,58),Y "RTN","DGPMGL",23,0) W !,$E("SSN Format"_L,1,58),$S(SS=1:"ENTIRE",1:"LAST FOUR OF")," SSN" "RTN","DGPMGL",24,0) W !,$E("Means Test Copay Applicability"_L,1,58),$S(MT:"",1:"NOT "),"DISPLAYED" "RTN","DGPMGL",25,0) W !,$E("Patient's Actual Treating Specialty"_L,1,58),$S(TS:"",1:"NOT "),"DISPLAYED" "RTN","DGPMGL",26,0) W !,$E("Show Non-Movements on G&L"_L,1,58),$S(SNM:"",1:"DON'T "),"SHOW" "RTN","DGPMGL",27,0) ;W !,$E("G&L Column Placement"_L,1,58),$S(CP=2:"TWO",1:"THREE")," COLUMN" "RTN","DGPMGL",28,0) W !,$E("Store Vietnam Vet's Remaining in CENSUS file"_L,1,58),$S(VN:"YES",1:"NO") "RTN","DGPMGL",29,0) W !,$E("Store Patient's over 65 y/o Remaining in CENSUS file"_L,1,58),$S(SF:"YES",1:"NO") "RTN","DGPMGL",30,0) ;W !,$E("Default Treating Specialty for UNKNOWN's"_L,1,58),$S($D(^DIC(45.7,+TSD,0)):$E($P(^(0),"^",1),1,20),1:"NONE SPECIFIED"),! K L "RTN","DGPMGL",31,0) Q "RTN","DGPMGL",32,0) ; "RTN","DGPMGL",33,0) GLR ; G&L Running "RTN","DGPMGL",34,0) S Y=+DGPM("GLS") I NOW-Y<.001 X ^DD("DD") W !,"G&L HAS BEEN RUNNING SINCE ",Y "RTN","DGPMGL",35,0) I $P(DGPM("GLS"),"^",3) D RCR "RTN","DGPMGL",36,0) Q "RTN","DGPMGL",37,0) ; "RTN","DGPMGL",38,0) RCR ; ReCalc Running "RTN","DGPMGL",39,0) Q:'$P(DGPM("GLS"),"^",3) S Y=$P(DGPM("GLS"),"^",3) X ^DD("DD") "RTN","DGPMGL",40,0) W !,"RECALCULATION IS RUNNING AND CURRENTLY PROCESSING ON ",Y,"." "RTN","DGPMGL",41,0) S RCR=1 "RTN","DGPMGL",42,0) Q "RTN","DGPMGL",43,0) ; "RTN","DGPMGL",44,0) RCR1 Q:'$P(DGPM("GLS"),"^",3) R !,"DO YOU WISH TO PRINT G&L ANYWAY" S %=2 D YN^DICN "RTN","DGPMGL",45,0) I '% W !?4,"Answer YES if you want to start G&L despite fact recalculation is running",!?4,"otherwise respond NO to abort this process.",*7,! G RCR1 "RTN","DGPMGL",46,0) S E=$S(%>0:%-1,1:2) "RTN","DGPMGL",47,0) I %=2 Q "RTN","DGPMGL",48,0) Q "RTN","DGPMGL",49,0) ; "RTN","DGPMGL",50,0) WD S WD=$O(^DIC(42,"AGL",0)) I WD'>0 W !!,"WARDS HAVE NOT BEEN DEFINED!" S E=1 Q "RTN","DGPMGL",51,0) S L=1,WD=$O(^DIC(42,"AGL",WD,0)) F J=1:1:7 S X1=DT,X2=J*-1 D C^%DTC S K=$S($D(^DG(41.9,+WD,"C",X,0)):^(0),1:0) Q:K S:J=7 L=0 "RTN","DGPMGL",52,0) S LD=X "RTN","DGPMGL",53,0) I TSRI]"" S D=$O(^DG(40.8,"ATS",0)) I D'>0 W !!,"TREATING SPECIALTIES HAVE NOT BEEN DEFINED FOR THE TSR!" Q "RTN","DGPMGL",54,0) I TSRI]"" S X=$O(^DG(40.8,"ATS",D,0)) S X=$O(^DG(40.8,"ATS",D,X,0)) I $D(^DG(40.8,D,"TS",X,"C","B")) I $D(^DG(40.8,D,"TS",X,"C",LD)) S TSLD=LD Q ; TSR census last date "RTN","DGPMGL",55,0) I TSRI]"" F D=0:0 S D=$O(^DG(40.8,"ATS",X,D)) Q:'D I $D(^DG(40.8,X,"TS",D,"C","B")) F J=0:0 S J=$O(^DG(40.8,X,"TS",D,"C","B",J)) Q:'J S TSLD=$O(^(J,0)) ; TSR census last date "RTN","DGPMGL",56,0) Q "RTN","DGPMGL",57,0) ; "RTN","DGPMGL",58,0) LAST I 'L W !!,"G&L HASN'T BEEN RUN IN LAST WEEK...RECALCULATION MUST BE RUN FIRST!!",*7 S E=2 Q "RTN","DGPMGL",59,0) S GL=1,X="GAINS AND LOSSES SHEET" D READ Q:E S:'X1 GL=0 "RTN","DGPMGL",60,0) S BS=1,X="BED STATUS REPORT" D READ G:E LAST S:'X1 BS=0 "RTN","DGPMGL",61,0) I TSRI']"" W !!,"TREATING SPECIALTY REPORT WILL NOT BE GENERATED UNTIL THE ",!,"TSR INITIALIZATION DATE IS DEFINED",*7 "RTN","DGPMGL",62,0) I '$D(TSLD) W !!,"TREATING SPECIALTY REPORT WILL NOT BE GENERATED UNTIL THE ",!,"RECALCULATION IS PERFORMED BACK TO THE TSR INITIALIZATION DATE",*7 "RTN","DGPMGL",63,0) S TSR=0 I $D(TSLD),TSRI]"" S TSR=1,X="TREATING SPECIALTY REPORT" D READ G:E LAST S:'X1 TSR=0 "RTN","DGPMGL",64,0) I 'BS,'GL,'TSR W !!,"NOTHING SELECTED!",*7 S E=2 Q "RTN","DGPMGL",65,0) Q "RTN","DGPMGL",66,0) ; "RTN","DGPMGL",67,0) READ S E=0 W !!,"PRINT ",X S %=1 D YN^DICN I % S X1=$S(%=1:%,1:0) S:%=-1 E=2 Q "RTN","DGPMGL",68,0) W !?4,"Answer YES if you wish to generate a ",X," for this date",!?4,"Otherwise answer NO." G READ "RTN","DGPMGL",69,0) Q "RTN","DGPMGL",70,0) ; "RTN","DGPMGL",71,0) ERR I E=1 W !!,"UNABLE TO PROCEED...CONTACT YOUR SYSTEMS MANAGER OR MAS ADPAC!",*7 "RTN","DGPMGL",72,0) ; "RTN","DGPMGL",73,0) Q K SS,MT,TS,CP,RM,OS,BS,GL,LD,NOW,DGPM,YD,REM,RD,CD,RC,PD,DIV,SF,SNM,TSD,VN,WD "RTN","DGPMGL",74,0) Q1 K %,X,Y,L,K,J,E,X1,C,I,X2,RCR "RTN","DGPMGL",75,0) Q "RTN","DGPMGL",76,0) ; "RTN","DGPMGL",77,0) ; "RTN","DGPMGL",78,0) DAT ; -- get params "RTN","DGPMGL",79,0) F X="G","GL","GLS",0 S DGPM(X)=$S($D(^DG(43,1,X)):^(X),1:"") "RTN","DGPMGL",80,0) S DIV=$S($P(DGPM("GL"),U,2):0,$D(^DG(40.8,+$P(DGPM("GL"),U,3),0)):+$P(DGPM("GL"),U,3),1:0) "RTN","DGPMGL",81,0) S X=DGPM("G"),SS=+$P(X,"^",2),MT=+$P(X,"^",3),TS=+$P(X,"^",4) "RTN","DGPMGL",82,0) S CP=+$P(X,"^",5),RM=132 S:$S(SS<6:1,TS:1,1:0) CP=2 "RTN","DGPMGL",83,0) S OS=$S(CP=2:(RM\2),1:(RM\3)),SNM=+$P(X,"^",6) "RTN","DGPMGL",84,0) S VN=+$P(X,"^",8),SF=+$P(X,"^",9),TSD=+$P(X,"^",10),TSRI=$P(X,"^",11) "RTN","DGPMGL",85,0) Q "RTN","DGPMGL",86,0) ; "RTN","DGPMGL",87,0) VAR ; WD=Ward ; LD=Last Date G&L was run ; BS=Bed Status ; GL=G&L ; "RTN","DGPMGL",88,0) ; SS=SSN format ; MT=Means Test display ; TS=Treating Speciality ; "RTN","DGPMGL",89,0) ; CP=Column Placement ; RM=Right Margin ; OS=OffSet ; "RTN","DGPMGL",90,0) ; SNM=Show Non-Movement ; VN=count Vietnam remaining ; "RTN","DGPMGL",91,0) ; SF=count > Sixty Five y/o ; TSD=Treating Speciality Default ; "RTN","DGPMGL5") 0^2^B5724705 "RTN","DGPMGL5",1,0) DGPMGL5 ;ALB/MRL - G&L PARAMETER ENTRY/EDIT; 29 APR 2003 "RTN","DGPMGL5",2,0) ;;5.3;Registration;**515**;Aug 13, 1993 "RTN","DGPMGL5",3,0) EN ; "RTN","DGPMGL5",4,0) D DIS,ASK "RTN","DGPMGL5",5,0) I Y D EDIT G EN "RTN","DGPMGL5",6,0) Q "RTN","DGPMGL5",7,0) ; "RTN","DGPMGL5",8,0) DIS ; -- display params "RTN","DGPMGL5",9,0) S DGPM=$S($D(^DG(43,1,"G")):^("G"),1:""),U="^" D DT^DICRW "RTN","DGPMGL5",10,0) S IOP="HOME" D ^%ZIS K IOP "RTN","DGPMGL5",11,0) W @IOF,!?27,"ENTER/EDIT G&L PARAMETERS",! K I S $P(I,"=",80)="" W I "RTN","DGPMGL5",12,0) W !,"G&L Initialization Date",?43,": " S Y=$P(DGPM,"^",1) X:Y ^DD("DD") W $S(Y]"":Y,1:"NOT SPECIFIED") "RTN","DGPMGL5",13,0) W !,"TSR Initialization Date",?43,": " S Y=$P(DGPM,"^",11) X:Y ^DD("DD") W $S(Y]"":Y,1:"NOT SPECIFIED") "RTN","DGPMGL5",14,0) W !,"SSN Format",?43,": DISPLAY ",$S($P(DGPM,"^",2)=6:"LAST FOUR ONLY",$P(DGPM,"^",2)=1:"ENTIRE SSN",1:"FORMAT UNSPECIFIED") "RTN","DGPMGL5",15,0) W !,"Means Test Copay Applicability Display",?43,": ",$S($P(DGPM,"^",3):"YES",1:"NO") "RTN","DGPMGL5",16,0) W !,"Patient's Treating Specialty (Display)",?43,": ",$S($P(DGPM,"^",4):"YES",1:"NO") "RTN","DGPMGL5",17,0) ;W !,"Display Names in Two or Three Columns",?43,": ",$S($P(DGPM,"^",5)=3:"THREE",1:"TWO") "RTN","DGPMGL5",18,0) W !,"Show Non-Movements on G&L",?43,": ",$S($P(DGPM,"^",6):"YES",1:"NO") "RTN","DGPMGL5",19,0) W !,"Recalculate From (Earliest Date to Recalc)",?43,": " S Y=$P(DGPM,"^",7) X:Y ^DD("DD") W $S(Y]"":Y,1:"UNSPECIFIED") "RTN","DGPMGL5",20,0) W !,"Count Vietnam Vets Remaining",?43,": ",$S($P(DGPM,"^",8):"YES",1:"NO") "RTN","DGPMGL5",21,0) W !,"Count Over 65'S Remaining (patients>65 y/o)",?43,": ",$S($P(DGPM,"^",9):"YES",1:"NO") "RTN","DGPMGL5",22,0) ;W !,"Default Treating Specialty",?43,": ",$S($D(^DIC(45.7,+$P(DGPM,"^",10),0)):$P(^(0),"^",1),1:"NOT SPECIFIED") "RTN","DGPMGL5",23,0) W !,"Days to Maintain G&L Corrections",?43,": ",$S($D(^DG(43,1,0)):+$P(^(0),U,29),1:0) "RTN","DGPMGL5",24,0) K I S $P(I,"=",80)="" W !,I "RTN","DGPMGL5",25,0) K I,DGPM Q "RTN","DGPMGL5",26,0) ; "RTN","DGPMGL5",27,0) ASK ; "RTN","DGPMGL5",28,0) S DIR(0)="Y",DIR("A")="Do you want to edit these parameters",DIR("B")="YES" "RTN","DGPMGL5",29,0) S DIR("?",1)=" 'Yes' to edit the G&L parameters" "RTN","DGPMGL5",30,0) S DIR("?",2)=" 'No' to not edit and quit" "RTN","DGPMGL5",31,0) S DIR("?")=" " "RTN","DGPMGL5",32,0) D ^DIR K DIR "RTN","DGPMGL5",33,0) Q "RTN","DGPMGL5",34,0) ; "RTN","DGPMGL5",35,0) EDIT ; -- edit params "RTN","DGPMGL5",36,0) W ! S DIE="^DG(43,",DA=1 S DR="1000.01;1000.11;1000.02:1000.04;1000.06:1000.09;5.5" D ^DIE "RTN","DGPMGL5",37,0) K DR,DIE,DA,DQ,DG,DE "RTN","DGPMGL5",38,0) Q "RTN","DGPMGLG5") 0^3^B6461431 "RTN","DGPMGLG5",1,0) DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 27 APR 2003 "RTN","DGPMGLG5",2,0) ;;5.3;Registration;**34,137,515**;Aug 13, 1993 "RTN","DGPMGLG5",3,0) ; "RTN","DGPMGLG5",4,0) A ; "RTN","DGPMGLG5",5,0) S NLS=0 ; non-loss indicator "RTN","DGPMGLG5",6,0) I MV("TT")=2!(MV("TT")=3) D NLS ; MV("TT")=2 (transfer) MV("TT")=3 (disch) "RTN","DGPMGLG5",7,0) I MV("TT")=1!(MV("TT")=3)!(MV("TT")=6) D ID ; MV("TT")=1 (adm) MV("TT")=6 (TS transfer) "RTN","DGPMGLG5",8,0) ; "RTN","DGPMGLG5",9,0) Q Q "RTN","DGPMGLG5",10,0) ; "RTN","DGPMGLG5",11,0) NLS ; Non-Loss "RTN","DGPMGLG5",12,0) S X=$P(MDP,"^",18) ; type of movement "RTN","DGPMGLG5",13,0) I "^1^2^3^25^26^"[("^"_X_"^") S NLS=+X ; NLS=1 (PASS), NLS=2 (AA), NLS=3 (UA), NLS=25 (FROM AA TO UA), NLS=26 (FROM UA TO AA) "RTN","DGPMGLG5",14,0) S:MV("MT")=42 NLS=42 ; WHILE ASIH "RTN","DGPMGLG5",15,0) S:MV("MT")=47 NLS=47 ; DISCHARGE FROM NHCU/DOM WHILE ASIH "RTN","DGPMGLG5",16,0) Q "RTN","DGPMGLG5",17,0) ; "RTN","DGPMGLG5",18,0) ID ; ID info for patient and legend LEG(X) setup "RTN","DGPMGLG5",19,0) ; Q:MV("TT")'=1!(MV("TT")'=3) ; 1=adm, 3=disch "RTN","DGPMGLG5",20,0) ; Means Test "RTN","DGPMGLG5",21,0) ;I MT,$D(^DG(41.3,DFN,0)) S X=9999999.999998-TO S X=+$O(^DG(41.3,DFN,2,X)) I $D(^(X,0)) S X=$P(^(0),"^",2) I "^A^B^C^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X "RTN","DGPMGLG5",22,0) I MT,$D(^DGMT(408.31,"C",DFN)) N DGX,X D "RTN","DGPMGLG5",23,0) . S DGX=$$MTIENLT^DGMTU3(1,DFN,-TO) "RTN","DGPMGLG5",24,0) . I $D(^DGMT(408.31,+DGX,0)) D "RTN","DGPMGLG5",25,0) . . S X=$P(^(0),"^",3),X=$P(^DG(408.32,+X,0),"^",2) "RTN","DGPMGLG5",26,0) . . I $G(X)="P" D ;evaluate pending adjudication to MT (C) or GMT (G) "RTN","DGPMGLG5",27,0) . . . I '$D(DGX) S X="U" Q "RTN","DGPMGLG5",28,0) . . . S X=$$PA^DGMTUTL(DGX),X=$S('$D(X):"U",X="MT":"C",X="GMT":"G",1:"U") "RTN","DGPMGLG5",29,0) . . I "^A^B^C^G^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X,DGX "RTN","DGPMGLG5",30,0) INS ; Reimburse Insurance (+) "RTN","DGPMGLG5",31,0) S INS=0 I $O(^DPT(DFN,.312,0)) S INS1=0 F JJ=0:0 S INS1=$O(^DPT(DFN,.312,INS1)) Q:INS1'>0 S I=^DPT(DFN,.312,INS1,0) I +$P(I,"^",8)'>TO I $D(^DIC(36,+I,0)),$P(^DIC(36,+I,0),"^",2)'="N" S INS=INS+1 I $P(I,"^",4)]""&($P(I,"^",4)'>TO) S INS=INS-1 "RTN","DGPMGLG5",32,0) S:INS>0 ID=ID_"+",LEG("+")="" "RTN","DGPMGLG5",33,0) K INS,INS1,JJ "RTN","DGPMGLG5",34,0) Q:MV("TT")'=3 "RTN","DGPMGLG5",35,0) ; While ASIH (*), Discharge after less than 48 hours (#) "RTN","DGPMGLG5",36,0) I $D(^DGPM(+MV("CA"),0)) S X=^(0) S:$P(X,"^",15) ID=ID_"*",LEG("*")="" S X1=+X,X2=2 D C^%DTC I +MD'>X S ID=ID_"#",LEG("#")="" K X,X1,X2 "RTN","DGPMGLG5",37,0) ; Absence (!) "RTN","DGPMGLG5",38,0) I MDP]"",$P(MDP,"^",2)=2 S X=$P(MDP,"^",18) I "^1^2^3^25^26^"[("^"_X_"^") S ID=ID_"!",LEG("!")="" K X "RTN","DGPMGLG5",39,0) Q "RTN","DGPMGLP") 0^4^B21935096 "RTN","DGPMGLP",1,0) DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003 "RTN","DGPMGLP",2,0) ;;5.3;Registration;**20,134,515**;Aug 13, 1993 "RTN","DGPMGLP",3,0) ; "RTN","DGPMGLP",4,0) A S DIE="^DG(43,",DA=1,DR="50///NOW" D ^DIE K DA,DR,DIE "RTN","DGPMGLP",5,0) S (RA,LA)="",$P(RA,"-",66)="",$P(LA,"-",66)="" ; RA=Right Arrows "-" LA=Left Arrows "-" "RTN","DGPMGLP",6,0) D 8 "RTN","DGPMGLP",7,0) F DGDIV=0:0 S DGDIV=$O(^UTILITY("DGT",$J,DGDIV)) Q:DGDIV="" S DGINST=DGDIV F DGSRV=0:0 S DGSRV=$O(^UTILITY("DGT",$J,DGDIV,DGSRV)) D:'DGSRV COR Q:'DGSRV D DIVHD,SRVHD,SCAN S:'$D(TTNAME) TTNAME="NT" D:$D(LEG)&(TTNAME'["NO TRANSACTION") FOOT "RTN","DGPMGLP",8,0) S DGINST=$P(^DG(40.8,DGINST,0),"^",7),DGINST=$P(^DIC(4,DGINST,0),"^") D COR1 "RTN","DGPMGLP",9,0) K K TTNAME,FMNAME,NAME,PTDATA,C,C1,DFN,FM,I,I1,I2,I3,L,LA,RA,TT,X,X1,Y,DGCR,DGDIV6,DGX,Y,J,DGINST "RTN","DGPMGLP",10,0) S DA=1,DIE="^DG(43,",DR="61///NOW;50///@" D ^DIE "RTN","DGPMGLP",11,0) K DA,DR,DIE "RTN","DGPMGLP",12,0) Q "RTN","DGPMGLP",13,0) ; "RTN","DGPMGLP",14,0) 8 ; If there are no transactions "RTN","DGPMGLP",15,0) F ORDER=0:0 S ORDER=$O(^DIC(42,"AGL",ORDER)) Q:'ORDER F WARD=0:0 S WARD=$O(^DIC(42,"AGL",ORDER,WARD)) Q:'WARD I $D(^DIC(42,WARD,0)) S X1=$P(^DIC(42,WARD,0),"^",3) I X1]"",X1'="NC" S DGSRV=$S(X1="NH":2,X1="D":3,1:1) D 88 "RTN","DGPMGLP",16,0) Q "RTN","DGPMGLP",17,0) 88 S DGDIV=$S($P(^DIC(42,WARD,0),"^",11)']"":+$P(DGPM("GL"),"^",3),1:$P(^DIC(42,WARD,0),"^",11)) D PARAM S:'$D(^UTILITY("DGT",$J,DGDIV,DGSRV)) ^UTILITY("DGT",$J,DGDIV,DGSRV,"8888")="" "RTN","DGPMGLP",18,0) Q "RTN","DGPMGLP",19,0) ; "RTN","DGPMGLP",20,0) PARAM ; --check combine/separate parameter in 40.8 "RTN","DGPMGLP",21,0) S DGDIV6=$S($D(^DG(40.8,DGDIV,0)):+$P(^(0),"^",6),1:0),DGSRV=$S('DGDIV6:1,1:DGSRV) Q "RTN","DGPMGLP",22,0) ; "RTN","DGPMGLP",23,0) DIVHD I $D(FF) W @IOF "RTN","DGPMGLP",24,0) S FF=1 "RTN","DGPMGLP",25,0) W !?94,"Date/Time Printed: ",DGNOW "RTN","DGPMGLP",26,0) W !?RM-22\2,"GAINS AND LOSSES SHEET" "RTN","DGPMGLP",27,0) S X=$$NAME^VASITE(RD) "RTN","DGPMGLP",28,0) I X']"" D "RTN","DGPMGLP",29,0) .S X="VA MEDICAL CENTER" "RTN","DGPMGLP",30,0) .S X=X_$S($D(^DG(40.8,+DGDIV,0)):", "_$P(^(0),"^"),1:"") S:DGDIV']"" X=X_" at "_DGINST "RTN","DGPMGLP",31,0) W !?RM-$L(X)\2,X "RTN","DGPMGLP",32,0) S X=RD D DW^%DTC "RTN","DGPMGLP",33,0) S Z="PERIOD ENDING MIDNIGHT "_X_", " "RTN","DGPMGLP",34,0) S Y=RD X ^DD("DD") "RTN","DGPMGLP",35,0) S X=Z_Y "RTN","DGPMGLP",36,0) W !?RM-$L(X)\2,X "RTN","DGPMGLP",37,0) K X,Z,Y "RTN","DGPMGLP",38,0) Q "RTN","DGPMGLP",39,0) ; "RTN","DGPMGLP",40,0) SRVHD ; -- print service head "RTN","DGPMGLP",41,0) S X=$P("MEDICAL CENTER^NHCU^DOMICILIARY","^",DGSRV)_" TOTALS" "RTN","DGPMGLP",42,0) W !?RM-$L(X)\2,X "RTN","DGPMGLP",43,0) Q "RTN","DGPMGLP",44,0) ; "RTN","DGPMGLP",45,0) SCAN ; -- scan entries "RTN","DGPMGLP",46,0) F TT=0:0 S TT=$O(^UTILITY("DGT",$J,DGDIV,DGSRV,TT)) Q:'TT S TTNAME=$S($D(^DG(405.3,+TT,0)):$P(^(0),"^"),TT=9999:"NON-LOSSES",TT=8888:"NO TRANSACTION",1:"UNKNOWN TRANSACTION TYPE")_"(S): "_$J(+^UTILITY("DGT",$J,DGDIV,DGSRV,TT),4) D ^DGPMGLP1 "RTN","DGPMGLP",47,0) Q "RTN","DGPMGLP",48,0) ; "RTN","DGPMGLP",49,0) FOOT W ! W:UL["-" ! "RTN","DGPMGLP",50,0) F L=1:1:131 W UL "RTN","DGPMGLP",51,0) S C=0,X="" "RTN","DGPMGLP",52,0) F I="+","*","#","!","a","b","c","g","r" S C=C+1 I $D(LEG(I)) S X="'"_I_"' - "_$P($T(LEG+C),";;",2)_"; " W:$X>(131-$L(X)) ! W X "RTN","DGPMGLP",53,0) W ! "RTN","DGPMGLP",54,0) Q "RTN","DGPMGLP",55,0) ; "RTN","DGPMGLP",56,0) LEG ; Legend "RTN","DGPMGLP",57,0) ;;Third Party Reimbursement Candidate "RTN","DGPMGLP",58,0) ;;While in Absent Sick in Hospital Status (ASIH) "RTN","DGPMGLP",59,0) ;;Discharge within 48 hours of admission "RTN","DGPMGLP",60,0) ;;While in Absence Status (authorized/unauthorized absence) "RTN","DGPMGLP",61,0) ;;MT Copay Exempt "RTN","DGPMGLP",62,0) ;;Category 'B' Veteran "RTN","DGPMGLP",63,0) ;;MT Copay Required "RTN","DGPMGLP",64,0) ;;GMT Copay Required "RTN","DGPMGLP",65,0) ;;Current Means Test Required but not completed "RTN","DGPMGLP",66,0) Q "RTN","DGPMGLP",67,0) ; "RTN","DGPMGLP",68,0) LINES W !!! "RTN","DGPMGLP",69,0) Q "RTN","DGPMGLP",70,0) COR ; From the Medical Center Division File, Census Multiple, Corrections to the Previous G&L's word processing field "RTN","DGPMGLP",71,0) ; "RTN","DGPMGLP",72,0) I $D(^DG(40.8,DGDIV,"CEN",RD,"A")) F I=0:0 S I=$O(^DG(40.8,DGDIV,"CEN",RD,"A",I)) Q:I="" D:$Y>62 DIVHD,LINES W !,^DG(40.8,DGDIV,"CEN",RD,"A",I,0) "RTN","DGPMGLP",73,0) Q "RTN","DGPMGLP",74,0) ; "RTN","DGPMGLP",75,0) COR1 ; From the G&L Corrections File "RTN","DGPMGLP",76,0) ; "RTN","DGPMGLP",77,0) I '$D(^UTILITY($J,"CR")) F I=0:0 S I=$O(^DGS(43.5,"B",RD,I)) Q:I="" I $D(^DGS(43.5,I,0)) S DGCR=^(0),^UTILITY($J,"CR",$S($D(^DPT(+$P(DGCR,"^",5),0)):$P(^(0),"^",1),1:"")_I)=DGCR "RTN","DGPMGLP",78,0) I $D(^UTILITY($J,"CR")) D DIVHD,LINES ; to print G&L Corrections File on separate page "RTN","DGPMGLP",79,0) S I="" F J=0:0 S I=$O(^UTILITY($J,"CR",I)) Q:I="" S DGCR=^(I) D COR2,CORR "RTN","DGPMGLP",80,0) Q "RTN","DGPMGLP",81,0) ; "RTN","DGPMGLP",82,0) COR2 Q:'$D(DGCR) "RTN","DGPMGLP",83,0) S DGX=$S($D(^DG(43.61,$P(DGCR,"^",2),0)):$P(^DG(43.61,$P(DGCR,"^",2),0),"^"),1:"") "RTN","DGPMGLP",84,0) Q "RTN","DGPMGLP",85,0) ; "RTN","DGPMGLP",86,0) CORR D:$Y>62 DIVHD,LINES "RTN","DGPMGLP",87,0) W !,DGX ; Type of change "RTN","DGPMGLP",88,0) W " For ",$S($D(^DPT(+$P(DGCR,"^",5),0)):$P(^(0),"^",1)_" "_$P(^(0),"^",9),1:" ") ; Patient name and SSN "RTN","DGPMGLP",89,0) I $P(DGCR,"^",6)]"" S Y=$P(DGCR,"^",6) X ^DD("DD") W " For admission of ",Y "RTN","DGPMGLP",90,0) I $P(DGCR,"^",9)]"" S Y=$P(DGCR,"^",9) X ^DD("DD") W ", transfer of ",Y "RTN","DGPMGLP",91,0) I $P(DGCR,"^",3)]"" W " Old value: ",$P(DGCR,"^",3) "RTN","DGPMGLP",92,0) I $P(DGCR,"^",4)]"" W " New value: ",$P(DGCR,"^",4) "RTN","DGPMGLP",93,0) Q "VER") 8.0^22 **END** **END**