DGABUL ;ALB/MRL/MJK - TRANSMIT OVERDUE ABSENCE BULLETIN; 23 OCT 1990
;;5.3;Registration;**418**;Aug 13, 1993
EN ;
Q:'$D(DUZ)#2
S U="^",Y=$S($D(^DG(43,1,"CON")):$P(^("CON"),"^",7),1:"") X:Y]"" ^DD("DD")
W !! I Y]"" W "OVERDUE ABSENCE SEARCH WAS LAST RUN ",Y,!
;
EN1 W "TRANSMIT OVERDUE ABSENCE BULLETIN" S %=2 D YN^DICN
I '% W !!?4,"Y - To search for inpatients overdue from AA, UA and PASS and transmit",!?9,"bulletin to select mailgroup.",!?4,"N - If you don't wish to search for overdue absences.",! G EN1
D QUE:%=1,Q Q
;
ST ;
N DGW K ^UTILITY($J) D H^DGUTL
S X1=DGTIME,X2=-4 D C^%DTC S DGDAY4=X
S X1=DGTIME,X2=-14 D C^%DTC S DGDAY14=X
S X1=DGTIME,X2=-30 D C^%DTC S DGDAY30=X
S DGT=DGTIME,DGW="",$P(^DG(43,1,"CON"),"^",7)=DGTIME
;
; -- overdues
F I=0:0 S DGW=$O(^DPT("CN",DGW)) Q:DGW="" F DFN=0:0 S DFN=$O(^DPT("CN",DGW,DFN)) Q:'DFN D ^DGINPW I DG1,DGA1 F %=0:0 S %=$O(^DGPM("APMV",DFN,DGA1,%)) Q:'% I %,$D(^DGPM(+$O(^(%,0)),0)) S DGD=^(0) I $P(DGD,U,2)=2 D 1:DGDAY4>DGD Q
G Q:'$D(^UTILITY($J,"DGOVER"))
;
; -- re-sort util for bulletin
S DGW="",C=0
F I=0:0 S DGW=$O(^UTILITY($J,"DGOVER",DGW)) Q:DGW="" S DGNAME="" F J=0:0 S DGNAME=$O(^UTILITY($J,"DGOVER",DGW,DGNAME)) Q:DGNAME="" S C=C+1,^UTILITY($J,"DGOV",C,0)=^UTILITY($J,"DGOVER",DGW,DGNAME)
K ^UTILITY($J,"DGOVER")
D BULL
;
Q ; -- clean up
K ^UTILITY($J),DFN,DG1,DGA1,DGD,DGD1,DGD2,DGDAY4,DGDAY14,DGDAY30,DGT,DGTIME,DGDATE,I,I1,J,J1,X,X1,X2,Y,DGXFR0,DGPMX D KILL^DGPATV
D CLOSE^DGUTQ S IOP="HOME" D ^%ZIS K IOP Q
;
1 ; -- process xfr
S DGD1=+DGD,DGD2=+$P(DGD,U,18)
I "^1^2^3^"'[("^"_DGD2_"^") G Q1
S DGD1=+DGD
I DGD2=1 D:DGD1<DGDAY4 S G Q1
I DGD2=2,"^NH^D^"[("^"_$P(^DIC(42,+DG1,0),"^",3)_"^")!($P(^DIC(42,+DG1,0),"^",17)=1) D:DGD1<DGDAY30 S G Q1 ;p-418
I DGD2=2 D:DGD1<DGDAY14 S G Q1
I DGD2=3 D:DGD1<DGDAY30 S
Q1 Q
;
S ; -- set util w/pt data for bull
D ^DGPATV S Y=DGD1 X ^DD("DD") S X=$E(DGW,1,10),X1="",$P(X1," ",30)="",X=$E(X_X1,1,15),X2=$E(DGNAME,1,25)_" ("_$E($P(SSN,"^",1),6,10)_")"_X1,X=X_$E(X2,1,30)
S X2=$S(DGD2=1:"PASS",DGD2=2:"AA",1:"UA")_" since "_Y,X=X_X2,^UTILITY($J,"DGOVER",DGW,DGNAME)=X K X,X1,X2 Q
;
BULL ; -- send bulletin
G BULLQ:'$D(^UTILITY($J,"DGOV"))
S Y=DGTIME X ^DD("DD") S XMSUB="OVERDUE ABSENCES AS OF "_Y,XMTEXT="^UTILITY($J,""DGOV"",",DGB=8 D ^DGBUL
BULLQ Q
;
QUE ; -- que search
S DGPGM="ST^DGABUL",DGVAR="DUZ^ION",ION="",X="NOW" D Q1^DGUTQ
W " ...BACKGROUND SEARCH QUEUED!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGABUL 2474 printed Dec 13, 2024@02:41:05 Page 2
DGABUL ;ALB/MRL/MJK - TRANSMIT OVERDUE ABSENCE BULLETIN; 23 OCT 1990
+1 ;;5.3;Registration;**418**;Aug 13, 1993
EN ;
+1 if '$DATA(DUZ)#2
QUIT
+2 SET U="^"
SET Y=$SELECT($DATA(^DG(43,1,"CON")):$PIECE(^("CON"),"^",7),1:"")
if Y]""
XECUTE ^DD("DD")
+3 WRITE !!
IF Y]""
WRITE "OVERDUE ABSENCE SEARCH WAS LAST RUN ",Y,!
+4 ;
EN1 WRITE "TRANSMIT OVERDUE ABSENCE BULLETIN"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !!?4,"Y - To search for inpatients overdue from AA, UA and PASS and transmit",!?9,"bulletin to select mailgroup.",!?4,"N - If you don't wish to search for overdue absences.",!
GOTO EN1
+2 if %=1
DO QUE
DO Q
QUIT
+3 ;
ST ;
+1 NEW DGW
KILL ^UTILITY($JOB)
DO H^DGUTL
+2 SET X1=DGTIME
SET X2=-4
DO C^%DTC
SET DGDAY4=X
+3 SET X1=DGTIME
SET X2=-14
DO C^%DTC
SET DGDAY14=X
+4 SET X1=DGTIME
SET X2=-30
DO C^%DTC
SET DGDAY30=X
+5 SET DGT=DGTIME
SET DGW=""
SET $PIECE(^DG(43,1,"CON"),"^",7)=DGTIME
+6 ;
+7 ; -- overdues
+8 FOR I=0:0
SET DGW=$ORDER(^DPT("CN",DGW))
if DGW=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DPT("CN",DGW,DFN))
if 'DFN
QUIT
DO ^DGINPW
IF DG1
IF DGA1
FOR %=0:0
SET %=$ORDER(^DGPM("APMV",DFN,DGA1,%))
if '%
QUIT
IF %
IF $DATA(^DGPM(+$ORDER(^(%,0)),0))
SET DGD=^(0)
IF $PIECE(DGD,U,2)=2
if DGDAY4>DGD
DO 1
QUIT
+9 if '$DATA(^UTILITY($JOB,"DGOVER"))
GOTO Q
+10 ;
+11 ; -- re-sort util for bulletin
+12 SET DGW=""
SET C=0
+13 FOR I=0:0
SET DGW=$ORDER(^UTILITY($JOB,"DGOVER",DGW))
if DGW=""
QUIT
SET DGNAME=""
FOR J=0:0
SET DGNAME=$ORDER(^UTILITY($JOB,"DGOVER",DGW,DGNAME))
if DGNAME=""
QUIT
SET C=C+1
SET ^UTILITY($JOB,"DGOV",C,0)=^UTILITY($JOB,"DGOVER",DGW,DGNAME)
+14 KILL ^UTILITY($JOB,"DGOVER")
+15 DO BULL
+16 ;
Q ; -- clean up
+1 KILL ^UTILITY($JOB),DFN,DG1,DGA1,DGD,DGD1,DGD2,DGDAY4,DGDAY14,DGDAY30,DGT,DGTIME,DGDATE,I,I1,J,J1,X,X1,X2,Y,DGXFR0,DGPMX
DO KILL^DGPATV
+2 DO CLOSE^DGUTQ
SET IOP="HOME"
DO ^%ZIS
KILL IOP
QUIT
+3 ;
1 ; -- process xfr
+1 SET DGD1=+DGD
SET DGD2=+$PIECE(DGD,U,18)
+2 IF "^1^2^3^"'[("^"_DGD2_"^")
GOTO Q1
+3 SET DGD1=+DGD
+4 IF DGD2=1
if DGD1<DGDAY4
DO S
GOTO Q1
+5 ;p-418
IF DGD2=2
IF "^NH^D^"[("^"_$PIECE(^DIC(42,+DG1,0),"^",3)_"^")!($PIECE(^DIC(42,+DG1,0),"^",17)=1)
if DGD1<DGDAY30
DO S
GOTO Q1
+6 IF DGD2=2
if DGD1<DGDAY14
DO S
GOTO Q1
+7 IF DGD2=3
if DGD1<DGDAY30
DO S
Q1 QUIT
+1 ;
S ; -- set util w/pt data for bull
+1 DO ^DGPATV
SET Y=DGD1
XECUTE ^DD("DD")
SET X=$EXTRACT(DGW,1,10)
SET X1=""
SET $PIECE(X1," ",30)=""
SET X=$EXTRACT(X_X1,1,15)
SET X2=$EXTRACT(DGNAME,1,25)_" ("_$EXTRACT($PIECE(SSN,"^",1),6,10)_")"_X1
SET X=X_$EXTRACT(X2,1,30)
+2 SET X2=$SELECT(DGD2=1:"PASS",DGD2=2:"AA",1:"UA")_" since "_Y
SET X=X_X2
SET ^UTILITY($JOB,"DGOVER",DGW,DGNAME)=X
KILL X,X1,X2
QUIT
+3 ;
BULL ; -- send bulletin
+1 if '$DATA(^UTILITY($JOB,"DGOV"))
GOTO BULLQ
+2 SET Y=DGTIME
XECUTE ^DD("DD")
SET XMSUB="OVERDUE ABSENCES AS OF "_Y
SET XMTEXT="^UTILITY($J,""DGOV"","
SET DGB=8
DO ^DGBUL
BULLQ QUIT
+1 ;
QUE ; -- que search
+1 SET DGPGM="ST^DGABUL"
SET DGVAR="DUZ^ION"
SET ION=""
SET X="NOW"
DO Q1^DGUTQ
+2 WRITE " ...BACKGROUND SEARCH QUEUED!!"
+3 QUIT
