DGPMGLP.m

DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003

 ;;5.3;Registration;**20,134,515,713,1015**;Aug 13, 1993;Build 21

 ;

A S DIE="^DG(43,",DA=1,DR="50///NOW" D ^DIE K DA,DR,DIE

 S (RA,LA)="",$P(RA,"-",66)="",$P(LA,"-",66)="" ;  RA=Right Arrows "-"   LA=Left Arrows "-"

 D 8

 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

 S DGINST=$P(^DG(40.8,DGINST,0),"^",7),DGINST=$P(^DIC(4,DGINST,0),"^") D COR1

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

 S DA=1,DIE="^DG(43,",DR="61///NOW;50///@" D ^DIE

 K DA,DR,DIE

 Q

 ;

8 ; If there are no transactions

 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

 Q

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")=""

 Q

 ;

PARAM ; --check combine/separate parameter in 40.8

 S DGDIV6=$S($D(^DG(40.8,DGDIV,0)):+$P(^(0),"^",6),1:0),DGSRV=$S('DGDIV6:1,1:DGSRV) Q

 ;

DIVHD I $D(FF) W @IOF

 S FF=1

 W !?94,"Date/Time Printed: ",DGNOW

 W !?RM-22\2,"GAINS AND LOSSES SHEET"

 S X=$$NAME^VASITE(RD)

 I X']"" D

 .S X="VA MEDICAL CENTER"

 .S X=X_$S($D(^DG(40.8,+DGDIV,0)):", "_$P(^(0),"^"),1:"") S:DGDIV']"" X=X_" at "_DGINST

 W !?RM-$L(X)\2,X

 S X=RD D DW^%DTC

 S Z="PERIOD ENDING MIDNIGHT "_X_", "

 S Y=RD X ^DD("DD")

 S X=Z_Y

 W !?RM-$L(X)\2,X

 K X,Z,Y

 Q

 ;

SRVHD ; -- print service head

 S X=$P("MEDICAL CENTER^NHCU^DOMICILIARY","^",DGSRV)_" TOTALS"

 W !?RM-$L(X)\2,X

 Q

 ;

SCAN ; -- scan entries

 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

 Q

 ;

FOOT W ! W:UL["-" !

 F L=1:1:131 W UL

 S C=0,X=""

 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

 W !

 Q

 ;

LEG ;  Legend

 ;;Third Party Reimbursement Candidate

 ;;While in Absent Sick in Hospital Status (ASIH)

 ;;Discharge within 48 hours of admission

 ;;While in Absence Status (authorized/unauthorized absence)

 ;;MT Copay Exempt

 ;;Category 'B' Veteran

 ;;MT Copay Required

 ;;GMT Copay Required

 ;;Current Means Test Required but not completed

 Q

 ;

LINES W !!!

 Q

COR ;  From the Medical Center Division File, Census Multiple, Corrections to the Previous G&L's word processing field

 ;

 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)

 Q

 ;

COR1 ;  From the G&L Corrections File

 ;

 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

 I $D(^UTILITY($J,"CR")) D DIVHD,LINES ; to print G&L Corrections File on separate page

 S I="" F J=0:0 S I=$O(^UTILITY($J,"CR",I)) Q:I=""  S DGCR=^(I) D COR2,CORR

 Q

 ;

COR2 Q:'$D(DGCR)

 S DGX=$S($D(^DG(43.61,$P(DGCR,"^",2),0)):$P(^DG(43.61,$P(DGCR,"^",2),0),"^"),1:"")

 Q

 ;

CORR D:$Y>62 DIVHD,LINES

 W !,DGX ; Type of change

 W " For ",$S($D(^DPT(+$P(DGCR,"^",5),0)):$P(^(0),"^",1)_"  "_$E($P(^(0),"^",9),6,9),1:" ") ; Patient name and SSN

 I $P(DGCR,"^",6)]"" S Y=$P(DGCR,"^",6) X ^DD("DD") W " For admission of ",Y

 I $P(DGCR,"^",9)]"" S Y=$P(DGCR,"^",9) X ^DD("DD") W ", transfer of ",Y

 I $P(DGCR,"^",3)]"" W " Old value: ",$P(DGCR,"^",3)

 I $P(DGCR,"^",4)]"" W " New value: ",$P(DGCR,"^",4)

 Q

DGPMGLP   ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003

 +1       ;;5.3;Registration;**20,134,515,713,1015**;Aug 13, 1993;Build 21

 +2       ;

A          SET DIE="^DG(43,"

           SET DA=1

           SET DR="50///NOW"

           DO ^DIE

           KILL DA,DR,DIE

 +1       ;  RA=Right Arrows "-"   LA=Left Arrows "-"

           SET (RA,LA)=""

           SET $PIECE(RA,"-",66)=""

           SET $PIECE(LA,"-",66)=""

 +2        DO 8

 +3        FOR DGDIV=0:0

               SET DGDIV=$ORDER(^UTILITY("DGT",$JOB,DGDIV))

               IF DGDIV=""

                   QUIT 

               SET DGINST=DGDIV

               FOR DGSRV=0:0

                   SET DGSRV=$ORDER(^UTILITY("DGT",$JOB,DGDIV,DGSRV))

                   IF 'DGSRV

                       DO COR

                   IF 'DGSRV

                       QUIT 

                   DO DIVHD

                   DO SRVHD

                   DO SCAN

                   IF '$DATA(TTNAME)

                       SET TTNAME="NT"

                   IF $DATA(LEG)&(TTNAME'["NO TRANSACTION")

                       DO FOOT

 +4        SET DGINST=$PIECE(^DG(40.8,DGINST,0),"^",7)

           SET DGINST=$PIECE(^DIC(4,DGINST,0),"^")

           DO COR1

K          KILL 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

 +1        SET DA=1

           SET DIE="^DG(43,"

           SET DR="61///NOW;50///@"

           DO ^DIE

 +2        KILL DA,DR,DIE

 +3        QUIT 

 +4       ;

8         ; If there are no transactions

 +1        FOR ORDER=0:0

               SET ORDER=$ORDER(^DIC(42,"AGL",ORDER))

               IF 'ORDER

                   QUIT 

               FOR WARD=0:0

                   SET WARD=$ORDER(^DIC(42,"AGL",ORDER,WARD))

                   IF 'WARD

                       QUIT 

                   IF $DATA(^DIC(42,WARD,0))

                       SET X1=$PIECE(^DIC(42,WARD,0),"^",3)

                       IF X1]""

                           IF X1'="NC"

                               SET DGSRV=$SELECT(X1="NH":2,X1="D":3,1:1)

                               DO 88

 +2        QUIT 

88         SET DGDIV=$SELECT($PIECE(^DIC(42,WARD,0),"^",11)']"":+$PIECE(DGPM("GL"),"^",3),1:$PIECE(^DIC(42,WARD,0),"^",11))

           DO PARAM

           IF '$DATA(^UTILITY("DGT",$JOB,DGDIV,DGSRV))

               SET ^UTILITY("DGT",$JOB,DGDIV,DGSRV,"8888")=""

 +1        QUIT 

 +2       ;

PARAM     ; --check combine/separate parameter in 40.8

 +1        SET DGDIV6=$SELECT($DATA(^DG(40.8,DGDIV,0)):+$PIECE(^(0),"^",6),1:0)

           SET DGSRV=$SELECT('DGDIV6:1,1:DGSRV)

           QUIT 

 +2       ;

DIVHD      IF $DATA(FF)

               WRITE @IOF

 +1        SET FF=1

 +2        WRITE !?94,"Date/Time Printed: ",DGNOW

 +3        WRITE !?RM-22\2,"GAINS AND LOSSES SHEET"

 +4        SET X=$$NAME^VASITE(RD)

 +5        IF X']""

               Begin DoDot:1

 +6                SET X="VA MEDICAL CENTER"

 +7                SET X=X_$SELECT($DATA(^DG(40.8,+DGDIV,0)):", "_$PIECE(^(0),"^"),1:"")

                   IF DGDIV']""

                       SET X=X_" at "_DGINST

               End DoDot:1

 +8        WRITE !?RM-$LENGTH(X)\2,X

 +9        SET X=RD

           DO DW^%DTC

 +10       SET Z="PERIOD ENDING MIDNIGHT "_X_", "

 +11       SET Y=RD

           XECUTE ^DD("DD")

 +12       SET X=Z_Y

 +13       WRITE !?RM-$LENGTH(X)\2,X

 +14       KILL X,Z,Y

 +15       QUIT 

 +16      ;

SRVHD     ; -- print service head

 +1        SET X=$PIECE("MEDICAL CENTER^NHCU^DOMICILIARY","^",DGSRV)_" TOTALS"

 +2        WRITE !?RM-$LENGTH(X)\2,X

 +3        QUIT 

 +4       ;

SCAN      ; -- scan entries

 +1        FOR TT=0:0

               SET TT=$ORDER(^UTILITY("DGT",$JOB,DGDIV,DGSRV,TT))

               IF 'TT

                   QUIT 

               SET TTNAME=$SELECT($DATA(^DG(405.3,+TT,0)):$PIECE(^(0),"^"),TT=9999:"NON-LOSSES",TT=8888:"NO TRANSACTION",1:"UNKNOWN TRANSACTION TYPE")_"(S): "_$JUSTIFY(+^UTILITY("DGT",$JOB,DGDIV,DGSRV,TT),4)

               DO ^DGPMGLP1

 +2        QUIT 

 +3       ;

FOOT       WRITE !

           IF UL["-"

               WRITE !

 +1        FOR L=1:1:131

               WRITE UL

 +2        SET C=0

           SET X=""

 +3        FOR I="+","*","#","!","a","b","c","g","r"

               SET C=C+1

               IF $DATA(LEG(I))

                   SET X="'"_I_"' - "_$PIECE($TEXT(LEG+C),";;",2)_"; "

                   IF $X>(131-$LENGTH(X))

                       WRITE !

                   WRITE X

 +4        WRITE !

 +5        QUIT 

 +6       ;

LEG       ;  Legend

 +1       ;;Third Party Reimbursement Candidate

 +2       ;;While in Absent Sick in Hospital Status (ASIH)

 +3       ;;Discharge within 48 hours of admission

 +4       ;;While in Absence Status (authorized/unauthorized absence)

 +5       ;;MT Copay Exempt

 +6       ;;Category 'B' Veteran

 +7       ;;MT Copay Required

 +8       ;;GMT Copay Required

 +9       ;;Current Means Test Required but not completed

 +10       QUIT 

 +11      ;

LINES      WRITE !!!

 +1        QUIT 

COR       ;  From the Medical Center Division File, Census Multiple, Corrections to the Previous G&L's word processing field

 +1       ;

 +2        IF $DATA(^DG(40.8,DGDIV,"CEN",RD,"A"))

               FOR I=0:0

                   SET I=$ORDER(^DG(40.8,DGDIV,"CEN",RD,"A",I))

                   IF I=""

                       QUIT 

                   IF $Y>62

                       DO DIVHD

                       DO LINES

                   WRITE !,^DG(40.8,DGDIV,"CEN",RD,"A",I,0)

 +3        QUIT 

 +4       ;

COR1      ;  From the G&L Corrections File

 +1       ;

 +2        IF '$DATA(^UTILITY($JOB,"CR"))

               FOR I=0:0

                   SET I=$ORDER(^DGS(43.5,"B",RD,I))

                   IF I=""

                       QUIT 

                   IF $DATA(^DGS(43.5,I,0))

                       SET DGCR=^(0)

                       SET ^UTILITY($JOB,"CR",$SELECT($DATA(^DPT(+$PIECE(DGCR,"^",5),0)):$PIECE(^(0),"^",1),1:"")_I)=DGCR

 +3       ; to print G&L Corrections File on separate page

           IF $DATA(^UTILITY($JOB,"CR"))

               DO DIVHD

               DO LINES

 +4        SET I=""

           FOR J=0:0

               SET I=$ORDER(^UTILITY($JOB,"CR",I))

               IF I=""

                   QUIT 

               SET DGCR=^(I)

               DO COR2

               DO CORR

 +5        QUIT 

 +6       ;

COR2       IF '$DATA(DGCR)

               QUIT 

 +1        SET DGX=$SELECT($DATA(^DG(43.61,$PIECE(DGCR,"^",2),0)):$PIECE(^DG(43.61,$PIECE(DGCR,"^",2),0),"^"),1:"")

 +2        QUIT 

 +3       ;

CORR       IF $Y>62

               DO DIVHD

               DO LINES

 +1       ; Type of change

           WRITE !,DGX

 +2       ; Patient name and SSN

           WRITE " For ",$SELECT($DATA(^DPT(+$PIECE(DGCR,"^",5),0)):$PIECE(^(0),"^",1)_"  "_$EXTRACT($PIECE(^(0),"^",9),6,9),1:" ")

 +3        IF $PIECE(DGCR,"^",6)]""

               SET Y=$PIECE(DGCR,"^",6)

               XECUTE ^DD("DD")

               WRITE " For admission of ",Y

 +4        IF $PIECE(DGCR,"^",9)]""

               SET Y=$PIECE(DGCR,"^",9)

               XECUTE ^DD("DD")

               WRITE ", transfer of ",Y

 +5        IF $PIECE(DGCR,"^",3)]""

               WRITE " Old value: ",$PIECE(DGCR,"^",3)

 +6        IF $PIECE(DGCR,"^",4)]""

               WRITE " New value: ",$PIECE(DGCR,"^",4)

 +7        QUIT