DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 29 APR 2003
;;5.3;Registration;**85,515,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 3/30/2001 replaced VA header with IHS one
; checked IHS census files for data
; commented out code we don't need
; 9/05/2001 added read so errors don't scroll off screen
;
;W !!,"<<<GAINS & LOSSES SHEET/BED STATUS REPORT/TREATING SPECIALTY REPORT>>>",! ;IHS/ANMC/LJF 3/30/2001
W !!,"<<< ADMISSIONS & DISCHARGES SHEET >>>" ;IHS/ANMC/LJF 3/30/2001
W !,"<< Also called GAINS & LOSSES [G&L] >>",! ;IHS/ANMC/LJF 3/30/2001
;
A D DT^DICRW S U="^" D NOW^%DTC S NOW=% D LO^DGUTL
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
G A^DGPMGL1
;
PCHK ; Parameter Check
D DAT S E=0
I 'DGPM("G") W !!,$S('$D(^DG(43,1,0)):"ADT SYSTEM",1:"G&L")," HASN'T BEEN INITIALIZED!!" S E=1 Q
; modified re FORUM [#16205729] to exclude 5.
;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 ;IHS/ANMC/LJF 3/30/2001
Q
;
PAR ; -- display params
S L="",$P(L,".",50)="",Y=+DGPM("G") X ^DD("DD")
W !,$E("Earliest Date for G&L"_L,1,58),Y
S Y=$P(DGPM("G"),"^",11) X ^DD("DD")
W !,$E("Earliest Date for Treating Specialty Report"_L,1,58),Y I Y']"" W "NOT DEFINED"
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")
W !,$E("Earliest Date to Recalculate"_L,1,58),Y
;
Q ;IHS/ANMC/LJF 3/30/2001
;
W !,$E("SSN Format"_L,1,58),$S(SS=1:"ENTIRE",1:"LAST FOUR OF")," SSN"
W !,$E("Means Test Copay Applicability"_L,1,58),$S(MT:"",1:"NOT "),"DISPLAYED"
W !,$E("Patient's Actual Treating Specialty"_L,1,58),$S(TS:"",1:"NOT "),"DISPLAYED"
W !,$E("Show Non-Movements on G&L"_L,1,58),$S(SNM:"",1:"DON'T "),"SHOW"
;W !,$E("G&L Column Placement"_L,1,58),$S(CP=2:"TWO",1:"THREE")," COLUMN"
W !,$E("Store Vietnam Vet's Remaining in CENSUS file"_L,1,58),$S(VN:"YES",1:"NO")
W !,$E("Store Patient's over 65 y/o Remaining in CENSUS file"_L,1,58),$S(SF:"YES",1:"NO")
;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
Q
;
GLR ; G&L Running
S Y=+DGPM("GLS") I NOW-Y<.001 X ^DD("DD") W !,"G&L HAS BEEN RUNNING SINCE ",Y
I $P(DGPM("GLS"),"^",3) D RCR
Q
;
RCR ; ReCalc Running
Q:'$P(DGPM("GLS"),"^",3) S Y=$P(DGPM("GLS"),"^",3) X ^DD("DD")
W !,"RECALCULATION IS RUNNING AND CURRENTLY PROCESSING ON ",Y,"."
S RCR=1
Q
;
RCR1 Q:'$P(DGPM("GLS"),"^",3) R !,"DO YOU WISH TO PRINT G&L ANYWAY" S %=2 D YN^DICN
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
S E=$S(%>0:%-1,1:2)
I %=2 Q
Q
;
WD S WD=$O(^DIC(42,"AGL",0)) I WD'>0 W !!,"WARDS HAVE NOT BEEN DEFINED!" S E=1 Q
;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 ;IHS/ANMC/LJF 3/30/2001
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(^BDGCWD(+WD,1,X,0)):^(0),1:0) Q:K S:J=7 L=0 ;IHS/ANMC/LJF 3/30/2001
S LD=X
Q ;IHS/ANMC/LJF 3/30/2001
;
I TSRI]"" S D=$O(^DG(40.8,"ATS",0)) I D'>0 W !!,"TREATING SPECIALTIES HAVE NOT BEEN DEFINED FOR THE TSR!" Q
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
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
Q
;
LAST I 'L W !!,"G&L HASN'T BEEN RUN IN LAST WEEK...RECALCULATION MUST BE RUN FIRST!!",*7 S E=2 Q
;
;IHS/ANMC/LJF 3/30/2001 set report variables
S (BS,TSR,GL)=1 Q
;IHS/ANMC/LJF 3/30/2001 end of changes; lines below not needed
;
S GL=1,X="GAINS AND LOSSES SHEET" D READ Q:E S:'X1 GL=0
S BS=1,X="BED STATUS REPORT" D READ G:E LAST S:'X1 BS=0
I TSRI']"" W !!,"TREATING SPECIALTY REPORT WILL NOT BE GENERATED UNTIL THE ",!,"TSR INITIALIZATION DATE IS DEFINED",*7
I '$D(TSLD) W !!,"TREATING SPECIALTY REPORT WILL NOT BE GENERATED UNTIL THE ",!,"RECALCULATION IS PERFORMED BACK TO THE TSR INITIALIZATION DATE",*7
S TSR=0 I $D(TSLD),TSRI]"" S TSR=1,X="TREATING SPECIALTY REPORT" D READ G:E LAST S:'X1 TSR=0
I 'BS,'GL,'TSR W !!,"NOTHING SELECTED!",*7 S E=2 Q
Q
;
READ S E=0 W !!,"PRINT ",X S %=1 D YN^DICN I % S X1=$S(%=1:%,1:0) S:%=-1 E=2 Q
W !?4,"Answer YES if you wish to generate a ",X," for this date",!?4,"Otherwise answer NO." G READ
Q
;
ERR I E=1 W !!,"UNABLE TO PROCEED...CONTACT YOUR SYSTEMS MANAGER OR MAS ADPAC!",*7
D PAUSE^BDGF ;IHS/ANMC/LJF 9/05/2001
;
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
Q1 K %,X,Y,L,K,J,E,X1,C,I,X2,RCR
Q
;
;
DAT ; -- get params
F X="G","GL","GLS",0 S DGPM(X)=$S($D(^DG(43,1,X)):^(X),1:"")
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)
;
Q ;IHS/ANMC/LJF 3/30/2001
;
S X=DGPM("G"),SS=+$P(X,"^",2),MT=+$P(X,"^",3),TS=+$P(X,"^",4)
S CP=+$P(X,"^",5),RM=132 S:$S(SS<6:1,TS:1,1:0) CP=2
S OS=$S(CP=2:(RM\2),1:(RM\3)),SNM=+$P(X,"^",6)
S VN=+$P(X,"^",8),SF=+$P(X,"^",9),TSD=+$P(X,"^",10),TSRI=$P(X,"^",11)
Q
;
VAR ; WD=Ward ; LD=Last Date G&L was run ; BS=Bed Status ; GL=G&L ;
; SS=SSN format ; MT=Means Test display ; TS=Treating Speciality ;
; CP=Column Placement ; RM=Right Margin ; OS=OffSet ;
; SNM=Show Non-Movement ; VN=count Vietnam remaining ;
; SF=count > Sixty Five y/o ; TSD=Treating Speciality Default ;
DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 29 APR 2003
+1 ;;5.3;Registration;**85,515,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 3/30/2001 replaced VA header with IHS one
+3 ; checked IHS census files for data
+4 ; commented out code we don't need
+5 ; 9/05/2001 added read so errors don't scroll off screen
+6 ;
+7 ;W !!,"<<<GAINS & LOSSES SHEET/BED STATUS REPORT/TREATING SPECIALTY REPORT>>>",! ;IHS/ANMC/LJF 3/30/2001
+8 ;IHS/ANMC/LJF 3/30/2001
WRITE !!,"<<< ADMISSIONS & DISCHARGES SHEET >>>"
+9 ;IHS/ANMC/LJF 3/30/2001
WRITE !,"<< Also called GAINS & LOSSES [G&L] >>",!
+10 ;
A DO DT^DICRW
SET U="^"
DO NOW^%DTC
SET NOW=%
DO LO^DGUTL
+1 DO PCHK
IF E
GOTO ERR
DO PAR
DO GLR
IF E
GOTO ERR
DO RCR1
IF %=2
GOTO Q
DO WD
IF E
GOTO ERR
DO LAST
IF E
GOTO ERR
DO Q1
+2 GOTO A^DGPMGL1
+3 ;
PCHK ; Parameter Check
+1 DO DAT
SET E=0
+2 IF 'DGPM("G")
WRITE !!,$SELECT('$DATA(^DG(43,1,0)):"ADT SYSTEM",1:"G&L")," HASN'T BEEN INITIALIZED!!"
SET E=1
QUIT
+3 ; modified re FORUM [#16205729] to exclude 5.
+4 ;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 ;IHS/ANMC/LJF 3/30/2001
+5 QUIT
+6 ;
PAR ; -- display params
+1 SET L=""
SET $PIECE(L,".",50)=""
SET Y=+DGPM("G")
XECUTE ^DD("DD")
+2 WRITE !,$EXTRACT("Earliest Date for G&L"_L,1,58),Y
+3 SET Y=$PIECE(DGPM("G"),"^",11)
XECUTE ^DD("DD")
+4 WRITE !,$EXTRACT("Earliest Date for Treating Specialty Report"_L,1,58),Y
IF Y']""
WRITE "NOT DEFINED"
+5 SET Y=$SELECT($PIECE(DGPM("G"),"^",7)']"":+DGPM("G"),$PIECE(DGPM("G"),"^",7)<+DGPM("G"):+DGPM("G"),1:$PIECE(DGPM("G"),"^",7))
XECUTE ^DD("DD")
+6 WRITE !,$EXTRACT("Earliest Date to Recalculate"_L,1,58),Y
+7 ;
+8 ;IHS/ANMC/LJF 3/30/2001
QUIT
+9 ;
+10 WRITE !,$EXTRACT("SSN Format"_L,1,58),$SELECT(SS=1:"ENTIRE",1:"LAST FOUR OF")," SSN"
+11 WRITE !,$EXTRACT("Means Test Copay Applicability"_L,1,58),$SELECT(MT:"",1:"NOT "),"DISPLAYED"
+12 WRITE !,$EXTRACT("Patient's Actual Treating Specialty"_L,1,58),$SELECT(TS:"",1:"NOT "),"DISPLAYED"
+13 WRITE !,$EXTRACT("Show Non-Movements on G&L"_L,1,58),$SELECT(SNM:"",1:"DON'T "),"SHOW"
+14 ;W !,$E("G&L Column Placement"_L,1,58),$S(CP=2:"TWO",1:"THREE")," COLUMN"
+15 WRITE !,$EXTRACT("Store Vietnam Vet's Remaining in CENSUS file"_L,1,58),$SELECT(VN:"YES",1:"NO")
+16 WRITE !,$EXTRACT("Store Patient's over 65 y/o Remaining in CENSUS file"_L,1,58),$SELECT(SF:"YES",1:"NO")
+17 ;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
+18 QUIT
+19 ;
GLR ; G&L Running
+1 SET Y=+DGPM("GLS")
IF NOW-Y<.001
XECUTE ^DD("DD")
WRITE !,"G&L HAS BEEN RUNNING SINCE ",Y
+2 IF $PIECE(DGPM("GLS"),"^",3)
DO RCR
+3 QUIT
+4 ;
RCR ; ReCalc Running
+1 IF '$PIECE(DGPM("GLS"),"^",3)
QUIT
SET Y=$PIECE(DGPM("GLS"),"^",3)
XECUTE ^DD("DD")
+2 WRITE !,"RECALCULATION IS RUNNING AND CURRENTLY PROCESSING ON ",Y,"."
+3 SET RCR=1
+4 QUIT
+5 ;
RCR1 IF '$PIECE(DGPM("GLS"),"^",3)
QUIT
READ !,"DO YOU WISH TO PRINT G&L ANYWAY"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !?4,"Answer YES if you want to start G&L despite fact recalculation is running",!?4,"otherwise respond NO to abort this process.",*7,!
GOTO RCR1
+2 SET E=$SELECT(%>0:%-1,1:2)
+3 IF %=2
QUIT
+4 QUIT
+5 ;
WD SET WD=$ORDER(^DIC(42,"AGL",0))
IF WD'>0
WRITE !!,"WARDS HAVE NOT BEEN DEFINED!"
SET E=1
QUIT
+1 ;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 ;IHS/ANMC/LJF 3/30/2001
+2 ;IHS/ANMC/LJF 3/30/2001
SET L=1
SET WD=$ORDER(^DIC(42,"AGL",WD,0))
FOR J=1:1:7
SET X1=DT
SET X2=J*-1
DO C^%DTC
SET K=$SELECT($DATA(^BDGCWD(+WD,1,X,0)):^(0),1:0)
IF K
QUIT
IF J=7
SET L=0
+3 SET LD=X
+4 ;IHS/ANMC/LJF 3/30/2001
QUIT
+5 ;
+6 IF TSRI]""
SET D=$ORDER(^DG(40.8,"ATS",0))
IF D'>0
WRITE !!,"TREATING SPECIALTIES HAVE NOT BEEN DEFINED FOR THE TSR!"
QUIT
+7 ; TSR census last date
IF TSRI]""
SET X=$ORDER(^DG(40.8,"ATS",D,0))
SET X=$ORDER(^DG(40.8,"ATS",D,X,0))
IF $DATA(^DG(40.8,D,"TS",X,"C","B"))
IF $DATA(^DG(40.8,D,"TS",X,"C",LD))
SET TSLD=LD
QUIT
+8 ; TSR census last date
IF TSRI]""
FOR D=0:0
SET D=$ORDER(^DG(40.8,"ATS",X,D))
IF 'D
QUIT
IF $DATA(^DG(40.8,X,"TS",D,"C","B"))
FOR J=0:0
SET J=$ORDER(^DG(40.8,X,"TS",D,"C","B",J))
IF 'J
QUIT
SET TSLD=$ORDER(^(J,0))
+9 QUIT
+10 ;
LAST IF 'L
WRITE !!,"G&L HASN'T BEEN RUN IN LAST WEEK...RECALCULATION MUST BE RUN FIRST!!",*7
SET E=2
QUIT
+1 ;
+2 ;IHS/ANMC/LJF 3/30/2001 set report variables
+3 SET (BS,TSR,GL)=1
QUIT
+4 ;IHS/ANMC/LJF 3/30/2001 end of changes; lines below not needed
+5 ;
+6 SET GL=1
SET X="GAINS AND LOSSES SHEET"
DO READ
IF E
QUIT
IF 'X1
SET GL=0
+7 SET BS=1
SET X="BED STATUS REPORT"
DO READ
IF E
GOTO LAST
IF 'X1
SET BS=0
+8 IF TSRI']""
WRITE !!,"TREATING SPECIALTY REPORT WILL NOT BE GENERATED UNTIL THE ",!,"TSR INITIALIZATION DATE IS DEFINED",*7
+9 IF '$DATA(TSLD)
WRITE !!,"TREATING SPECIALTY REPORT WILL NOT BE GENERATED UNTIL THE ",!,"RECALCULATION IS PERFORMED BACK TO THE TSR INITIALIZATION DATE",*7
+10 SET TSR=0
IF $DATA(TSLD)
IF TSRI]""
SET TSR=1
SET X="TREATING SPECIALTY REPORT"
DO READ
IF E
GOTO LAST
IF 'X1
SET TSR=0
+11 IF 'BS
IF 'GL
IF 'TSR
WRITE !!,"NOTHING SELECTED!",*7
SET E=2
QUIT
+12 QUIT
+13 ;
READ SET E=0
WRITE !!,"PRINT ",X
SET %=1
DO YN^DICN
IF %
SET X1=$SELECT(%=1:%,1:0)
IF %=-1
SET E=2
QUIT
+1 WRITE !?4,"Answer YES if you wish to generate a ",X," for this date",!?4,"Otherwise answer NO."
GOTO READ
+2 QUIT
+3 ;
ERR IF E=1
WRITE !!,"UNABLE TO PROCEED...CONTACT YOUR SYSTEMS MANAGER OR MAS ADPAC!",*7
+1 ;IHS/ANMC/LJF 9/05/2001
DO PAUSE^BDGF
+2 ;
Q KILL SS,MT,TS,CP,RM,OS,BS,GL,LD,NOW,DGPM,YD,REM,RD,CD,RC,PD,DIV,SF,SNM,TSD,VN,WD
Q1 KILL %,X,Y,L,K,J,E,X1,C,I,X2,RCR
+1 QUIT
+2 ;
+3 ;
DAT ; -- get params
+1 FOR X="G","GL","GLS",0
SET DGPM(X)=$SELECT($DATA(^DG(43,1,X)):^(X),1:"")
+2 SET DIV=$SELECT($PIECE(DGPM("GL"),U,2):0,$DATA(^DG(40.8,+$PIECE(DGPM("GL"),U,3),0)):+$PIECE(DGPM("GL"),U,3),1:0)
+3 ;
+4 ;IHS/ANMC/LJF 3/30/2001
QUIT
+5 ;
+6 SET X=DGPM("G")
SET SS=+$PIECE(X,"^",2)
SET MT=+$PIECE(X,"^",3)
SET TS=+$PIECE(X,"^",4)
+7 SET CP=+$PIECE(X,"^",5)
SET RM=132
IF $SELECT(SS<6
SET CP=2
+8 SET OS=$SELECT(CP=2:(RM\2),1:(RM\3))
SET SNM=+$PIECE(X,"^",6)
+9 SET VN=+$PIECE(X,"^",8)
SET SF=+$PIECE(X,"^",9)
SET TSD=+$PIECE(X,"^",10)
SET TSRI=$PIECE(X,"^",11)
+10 QUIT
+11 ;
VAR ; WD=Ward ; LD=Last Date G&L was run ; BS=Bed Status ; GL=G&L ;
+1 ; SS=SSN format ; MT=Means Test display ; TS=Treating Speciality ;
+2 ; CP=Column Placement ; RM=Right Margin ; OS=OffSet ;
+3 ; SNM=Show Non-Movement ; VN=count Vietnam remaining ;
+4 ; SF=count > Sixty Five y/o ; TSD=Treating Speciality Default ;
