- DGABUL ;ALB/MRL/MJK - TRANSMIT OVERDUE ABSENCE BULLETIN; 23 OCT 1990
- ;;5.3;Registration;**418,1015**;Aug 13, 1993;Build 21
- 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
- DGABUL ;ALB/MRL/MJK - TRANSMIT OVERDUE ABSENCE BULLETIN; 23 OCT 1990
- +1 ;;5.3;Registration;**418,1015**;Aug 13, 1993;Build 21
- 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
