- DGA4001 ;ALB/MRL - LIST PENDING OR OPEN DISPOSITIONS ;01 JAN 1988@2300
- ;;5.3;Registration;**162**;Aug 13, 1993
- D UP^DGA400 I IO=DGDEV W !!,"===> Checking for Pending/Open Dispositions..."
- D VAR,H^DGUTL S $P(^DG(43,1,"AMIS"),"^",1)=DGTIME,Y=DGA1 X ^DD("DD") S DGH="PENDING/OPEN DISPOSITIONS, ",X="MONTH OF '"_Y_"'.",DGH=DGH_X,$P(^DG(43,1,"AMIS"),"^",6)=X
- EN2 K ^UTILITY($J) F I=DGA1:0 S I=$O(^DPT("ADIS",I)) Q:'I!(I>DGAE1) F DFN=0:0 S DFN=$O(^DPT("ADIS",I,DFN)) Q:'DFN F I1=0:0 S I1=$O(^DPT("ADIS",I,DFN,I1)) Q:'I1 I $D(^DPT(DFN,"DIS",I1,0)) S DGAD=^(0) D SET
- F I=0:0 S I=$O(^UTILITY($J,"DGDISP",I)),DGAP="" Q:'I D DV,HD F I1=0:0 S DGAP=$O(^UTILITY($J,"DGDISP",I,DGAP)) Q:DGAP="" F I2=0:0 S I2=$O(^UTILITY($J,"DGDISP",I,DGAP,I2)) Q:'I2 S X=^(I2) D WR
- Q W !! W:DGO!(DGP) DGL1,!! G QUIT1^DGA4002:DGQUIT
- D:DGHOME MES I DGO D ^DGA4003 G QUIT^DGA4002
- D PMES^DGA4003:DGP S DGA=DGA1 K %DT,DFN,DGA1,DGAD,DGAE1,DGAP,DGC,DGDATE,DGTIME,DGDV,DGH,DGHOME,DGL,DGL1,DGO,DGP,DGPGM,DGQUIT G ^DGA4004
- WR I $Y>$S($D(IOSL):(IOSL-4),1:20) W !,DGL1 D HD
- W !,$E($P(DGAP,",",1)_","_$E(DGAP,$F(DGAP,",")),1,20),?22,$P(X,"^",1)
- S X1="" I +I2 S X1=$E(I2,1,12),X1=$$FMTE^XLFDT(X1,"5F"),X1=$TR(X1," ","0")
- W ?29,X1,?50,$P(X,"^",2),?72,$P(X,"^",3) Q
- HD W @IOF,!,DGH,!,"DIVISION: ",$P(DGDV,"^",2) S Y=DT X ^DD("DD") S X1="Date Printed: "_Y W ?(78-$L(X1)),X1,!!,"Patient Name",?22,"PT ID",?29,"Reg. Date/Time",?50,"Application Type",?72,"Status",!,DGL,! Q
- DV I $D(^DG(43,1,"GL")),'$P(^("GL"),"^",2) S DGDV=$S($O(^DG(40.8,0))>0:$O(^DG(40.8,0)),1:"UNKNOWN") I DGDV S DGDV=DGDV_"^"_$P(^DG(40.8,+DGDV,0),"^",1) Q
- S DGDV=I_"^"_$S($D(^DG(40.8,+I,0)):$P(^(0),"^",1),1:"UNKNOWN") Q
- SET Q:$P(DGAD,U,2)=1&(I>2891000) W:IO=DGDEV "." I $P(DGAD,"^",6),$D(^DIC(37,+$P(DGAD,"^",7),0)),+$P(^(0),"^",9),$P(^(0),"^",9)'=13 D:'DGO SET1 Q
- S DGAP=$S($D(^DPT(DFN,0)):^(0),1:"") I $P(DGAD,"^",6),$P(DGAD,"^",7)]"" S DGS=" PEND",DGP=DGP+1
- E S DGS="**OPEN",DGO=DGO+1
- D PID^VADPT6 S X=$S(VA("BID"):VA("BID"),1:"NONE")_"^"_$S($P(DGAD,"^",3)=1:"Hospital",$P(DGAD,"^",3)=2:"Domiciliary",$P(DGAD,"^",3)=3:"OP Medical",$P(DGAD,"^",3)=4:"OP Dental",$P(DGAD,"^",3)=5:"Nursing Home",1:"Unknown")_"^"_DGS K VA
- S ^UTILITY($J,"DGDISP",+$P(DGAD,"^",4),$S($P(DGAP,"^",1)]"":$P(DGAP,"^",1),1:"UNKNOWN"),$P(DGAD,"^",1))=X Q:DGO
- SET1 S ^UTILITY($J,"DGDIS",DFN,I1)=DGAD,DGC=DGC+1 Q
- ;
- EN D VAR S DGDEV=IO,DGQUIT=1,%DT(0)=-DT,%DT="EAX",%DT("A")="Start with REGISTRATION DATE: " D ^%DT G Q:Y'>0 S DGA1=$P(Y,".",1)
- EN1 S %DT(0)=-DT,%DT="EAX",%DT("A")=" Go to REGISTRATION DATE: " D ^%DT G Q:Y'>0 I $S(DGA1=Y:0,Y'>DGA1:1,1:0) W !?4,*7,"MUST BE AFTER START DATE!" G EN1
- S DGAE1=$P(Y,".",1)_".2359",Y=DGA1 X ^DD("DD") S DGH="PENDING/OPEN DISPOSITIONS FOR '"_Y_"'" I $E(DGA1,1,7)=$E(DGAE1,1,7) S DGH=DGH_"."
- E S Y=$E(DGAE1,1,7) X ^DD("DD") S DGH=DGH_" THROUGH '"_Y_"'."
- S X1=DGA1,X2="-1" D C^%DTC S DGA1=X_".2359",DGPGM="EN2^DGA4001",DGVAR="DUZ^DGDEV^DGL^DGL1^DGQUIT^DGA1^DGAE1^DGH^DGO^DGP^DGC" D ZIS^DGUTQ G Q:POP U IO
- G EN2
- UP D H^DGUTL S $P(^DG(43,1,"AMIS"),"^",2)=DGTIME,$P(^("AMIS"),"^",5)=0 K DGDATE,DGTIME Q
- VAR S:'$D(DTIME) DTIME=300 S:'$D(U) U="^" I '$D(DT) S %DT="",X="T" D ^%DT
- S (DGO,DGP,DGC,DGL,DGL1)="",$P(DGL,"=",79)="",$P(DGL1,"#",79)="" ;S IOP=$S($D(ION):ION,1:IO) D ^%ZIS K IOP Q
- Q
- S (DGO,DGP,DGC,DGL,DGL1)="",$P(DGL,"=",79)="",$P(DGL1,"#",79)="" S IOP=$S($D(ION):ION,1:IO) D ^%ZIS K IOP Q
- MES W !!,"'",+DGP,"' Pending Dispositions on file...",!,"'",+DGO,"' Open Dispositions on file..."
- I +DGO W !!,"I can't let you generate this report with ""open"" dispositions remaining!",!,"Clear them up and try again later please.",! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGA4001 3634 printed Feb 19, 2025@00:07:02 Page 2
- DGA4001 ;ALB/MRL - LIST PENDING OR OPEN DISPOSITIONS ;01 JAN 1988@2300
- +1 ;;5.3;Registration;**162**;Aug 13, 1993
- +2 DO UP^DGA400
- IF IO=DGDEV
- WRITE !!,"===> Checking for Pending/Open Dispositions..."
- +3 DO VAR
- DO H^DGUTL
- SET $PIECE(^DG(43,1,"AMIS"),"^",1)=DGTIME
- SET Y=DGA1
- XECUTE ^DD("DD")
- SET DGH="PENDING/OPEN DISPOSITIONS, "
- SET X="MONTH OF '"_Y_"'."
- SET DGH=DGH_X
- SET $PIECE(^DG(43,1,"AMIS"),"^",6)=X
- EN2 KILL ^UTILITY($JOB)
- FOR I=DGA1:0
- SET I=$ORDER(^DPT("ADIS",I))
- if 'I!(I>DGAE1)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DPT("ADIS",I,DFN))
- if 'DFN
- QUIT
- FOR I1=0:0
- SET I1=$ORDER(^DPT("ADIS",I,DFN,I1))
- if 'I1
- QUIT
- IF $DATA(^DPT(DFN,"DIS",I1,0))
- SET DGAD=^(0)
- DO SET
- +1 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"DGDISP",I))
- SET DGAP=""
- if 'I
- QUIT
- DO DV
- DO HD
- FOR I1=0:0
- SET DGAP=$ORDER(^UTILITY($JOB,"DGDISP",I,DGAP))
- if DGAP=""
- QUIT
- FOR I2=0:0
- SET I2=$ORDER(^UTILITY($JOB,"DGDISP",I,DGAP,I2))
- if 'I2
- QUIT
- SET X=^(I2)
- DO WR
- Q WRITE !!
- if DGO!(DGP)
- WRITE DGL1,!!
- if DGQUIT
- GOTO QUIT1^DGA4002
- +1 if DGHOME
- DO MES
- IF DGO
- DO ^DGA4003
- GOTO QUIT^DGA4002
- +2 if DGP
- DO PMES^DGA4003
- SET DGA=DGA1
- KILL %DT,DFN,DGA1,DGAD,DGAE1,DGAP,DGC,DGDATE,DGTIME,DGDV,DGH,DGHOME,DGL,DGL1,DGO,DGP,DGPGM,DGQUIT
- GOTO ^DGA4004
- WR IF $Y>$SELECT($DATA(IOSL):(IOSL-4),1:20)
- WRITE !,DGL1
- DO HD
- +1 WRITE !,$EXTRACT($PIECE(DGAP,",",1)_","_$EXTRACT(DGAP,$FIND(DGAP,",")),1,20),?22,$PIECE(X,"^",1)
- +2 SET X1=""
- IF +I2
- SET X1=$EXTRACT(I2,1,12)
- SET X1=$$FMTE^XLFDT(X1,"5F")
- SET X1=$TRANSLATE(X1," ","0")
- +3 WRITE ?29,X1,?50,$PIECE(X,"^",2),?72,$PIECE(X,"^",3)
- QUIT
- HD WRITE @IOF,!,DGH,!,"DIVISION: ",$PIECE(DGDV,"^",2)
- SET Y=DT
- XECUTE ^DD("DD")
- SET X1="Date Printed: "_Y
- WRITE ?(78-$LENGTH(X1)),X1,!!,"Patient Name",?22,"PT ID",?29,"Reg. Date/Time",?50,"Application Type",?72,"Status",!,DGL,!
- QUIT
- DV IF $DATA(^DG(43,1,"GL"))
- IF '$PIECE(^("GL"),"^",2)
- SET DGDV=$SELECT($ORDER(^DG(40.8,0))>0:$ORDER(^DG(40.8,0)),1:"UNKNOWN")
- IF DGDV
- SET DGDV=DGDV_"^"_$PIECE(^DG(40.8,+DGDV,0),"^",1)
- QUIT
- +1 SET DGDV=I_"^"_$SELECT($DATA(^DG(40.8,+I,0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
- QUIT
- SET if $PIECE(DGAD,U,2)=1&(I>2891000)
- QUIT
- if IO=DGDEV
- WRITE "."
- IF $PIECE(DGAD,"^",6)
- IF $DATA(^DIC(37,+$PIECE(DGAD,"^",7),0))
- IF +$PIECE(^(0),"^",9)
- IF $PIECE(^(0),"^",9)'=13
- if 'DGO
- DO SET1
- QUIT
- +1 SET DGAP=$SELECT($DATA(^DPT(DFN,0)):^(0),1:"")
- IF $PIECE(DGAD,"^",6)
- IF $PIECE(DGAD,"^",7)]""
- SET DGS=" PEND"
- SET DGP=DGP+1
- +2 IF '$TEST
- SET DGS="**OPEN"
- SET DGO=DGO+1
- +3 DO PID^VADPT6
- SET X=$SELECT(VA("BID"):VA("BID"),1:"NONE")_"^"_$SELECT($PIECE(DGAD,"^",3)=1:"Hospital",$PIECE(DGAD,"^",3)=2:"Domiciliary",$PIECE(DGAD,"^",3)=3:"OP Medical",$PIECE(DGAD,"^",3)=4:"OP Dental",$PIECE(DGAD,"^",3)=5:"Nursing Home",1:"Unknown")_"^"_D
- GS
- KILL VA
- +4 SET ^UTILITY($JOB,"DGDISP",+$PIECE(DGAD,"^",4),$SELECT($PIECE(DGAP,"^",1)]"":$PIECE(DGAP,"^",1),1:"UNKNOWN"),$PIECE(DGAD,"^",1))=X
- if DGO
- QUIT
- SET1 SET ^UTILITY($JOB,"DGDIS",DFN,I1)=DGAD
- SET DGC=DGC+1
- QUIT
- +1 ;
- EN DO VAR
- SET DGDEV=IO
- SET DGQUIT=1
- SET %DT(0)=-DT
- SET %DT="EAX"
- SET %DT("A")="Start with REGISTRATION DATE: "
- DO ^%DT
- if Y'>0
- GOTO Q
- SET DGA1=$PIECE(Y,".",1)
- EN1 SET %DT(0)=-DT
- SET %DT="EAX"
- SET %DT("A")=" Go to REGISTRATION DATE: "
- DO ^%DT
- if Y'>0
- GOTO Q
- IF $SELECT(DGA1=Y:0,Y'>DGA1:1,1:0)
- WRITE !?4,*7,"MUST BE AFTER START DATE!"
- GOTO EN1
- +1 SET DGAE1=$PIECE(Y,".",1)_".2359"
- SET Y=DGA1
- XECUTE ^DD("DD")
- SET DGH="PENDING/OPEN DISPOSITIONS FOR '"_Y_"'"
- IF $EXTRACT(DGA1,1,7)=$EXTRACT(DGAE1,1,7)
- SET DGH=DGH_"."
- +2 IF '$TEST
- SET Y=$EXTRACT(DGAE1,1,7)
- XECUTE ^DD("DD")
- SET DGH=DGH_" THROUGH '"_Y_"'."
- +3 SET X1=DGA1
- SET X2="-1"
- DO C^%DTC
- SET DGA1=X_".2359"
- SET DGPGM="EN2^DGA4001"
- SET DGVAR="DUZ^DGDEV^DGL^DGL1^DGQUIT^DGA1^DGAE1^DGH^DGO^DGP^DGC"
- DO ZIS^DGUTQ
- if POP
- GOTO Q
- USE IO
- +4 GOTO EN2
- UP DO H^DGUTL
- SET $PIECE(^DG(43,1,"AMIS"),"^",2)=DGTIME
- SET $PIECE(^("AMIS"),"^",5)=0
- KILL DGDATE,DGTIME
- QUIT
- VAR if '$DATA(DTIME)
- SET DTIME=300
- if '$DATA(U)
- SET U="^"
- IF '$DATA(DT)
- SET %DT=""
- SET X="T"
- DO ^%DT
- +1 ;S IOP=$S($D(ION):ION,1:IO) D ^%ZIS K IOP Q
- SET (DGO,DGP,DGC,DGL,DGL1)=""
- SET $PIECE(DGL,"=",79)=""
- SET $PIECE(DGL1,"#",79)=""
- +2 QUIT
- +3 SET (DGO,DGP,DGC,DGL,DGL1)=""
- SET $PIECE(DGL,"=",79)=""
- SET $PIECE(DGL1,"#",79)=""
- SET IOP=$SELECT($DATA(ION):ION,1:IO)
- DO ^%ZIS
- KILL IOP
- QUIT
- MES WRITE !!,"'",+DGP,"' Pending Dispositions on file...",!,"'",+DGO,"' Open Dispositions on file..."
- +1 IF +DGO
- WRITE !!,"I can't let you generate this report with ""open"" dispositions remaining!",!,"Clear them up and try again later please.",!
- QUIT