DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003
;;5.3;Registration;**20,134,515,713**;Aug 13, 1993
;
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
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMGLP 3957 printed Oct 16, 2024@18:50:20 Page 2
DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003
+1 ;;5.3;Registration;**20,134,515,713**;Aug 13, 1993
+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 ;
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
