- DGOASIH ;ALB/VAD - LIST OF PATIENTS ON ASIH ;Sep 27 1999
- ;;5.3;Registration;**162,227**;Aug 13, 1993
- ;
- ; PATCH 5.3*227 ADDED SEP 27 1999 BY VAD
- ; Rather than only allow for the entry of tomorrow's date, the
- ; ability to enter any future date has been added. However, if
- ; a future date is entered, then a warning message will display
- ; stating that the report should be tasked to prevent the printing
- ; of a negative report. Line EN3 has been split to allow for the
- ; code for this patch to be added.
- ;
- EN3 K TD,DGF S %DT="AEXPT",%DT("A")="Enter date of ASIH: " D ^%DT G QUIT:Y'>0
- ; *** Start of patched code inserted for 5.3*227 - VAD.
- I +Y>+DT D G:DGU QUIT
- . W !!?10,$C(7),"You have entered a future date...to prevent the printing"
- . W !?10,"of a negative report, remember to task this request for"
- . W !?10,"the appropriate date."
- . S DGU=0 D RT
- ; *** End of patched code.
- ;
- S DGT=+Y,DGT=$S(DGT[".":DGT,1:DGT_".2400")
- S Y=DGT X ^DD("DD") S DGDAY=$P(Y,"@") S DGHD="ASIH LIST FOR "_Y,X1=DT,X2=-30 D C^%DTC S DGPG=0
- S DGVAR="DGT^DGPG^DGDAY^DGHD",DGPGM="START^DGOASIH" D ZIS^DGUTQ I 'POP U IO D START^DGOASIH
- QUIT K DGHD,DGST I '$D(ZTQUEUED) D CLOSE^DGUTQ
- QUIT1 K %,%I,%T,%DT,DFN,DG2,DGADM,DGCA,DGCD,DGCL,DGD,DGDAY,DGDV,DGFL,DGI,DGJ,DGLV,DGNO,DGP,DGPG,DGPGM,DGRT,DGSTART,DGT,DGTIME,DGTP,DGU,DGVAR,DGW,DGA,DGDAT,DGDFN,DGDT,DGIFN,DGNOW,DGTYP,DGX,DGY,POP,VA,VADAT,VADATE,VAERR,^UTILITY($J,"DG"),X,X1,X2,Y
- K M,VAIP,VAIP("D") Q
- START D NOW^%DTC S Y=$E(%,1,12) S DGTIME=$$FMTE^XLFDT(Y,1) S $P(DGCL,"-",81)="",DGFL=0,X1=DGT,X2=-32 D C^%DTC S DGSTART=X
- D NOW^%DTC S DGNOW=%
- S DGA="^13^43^44^45^"
- S DGDAT=DGT,DGST=0,DGPG=0
- F DGDT=DGSTART:0 S DGDT=$O(^DGPM("AMV2",DGDT)) Q:'DGDT!(DGDT>DGDAT) F DFN=0:0 S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN F DGIFN=0:0 S DGIFN=$O(^DGPM("AMV2",DGDT,DFN,DGIFN)) Q:'DGIFN S DGASIH=1 D CK^DGPASS Q:DGFL
- K DGASIH I '$D(^UTILITY($J,"DG")) W !!?8,"*** THERE ARE NO PATIENTS OUT ON ASIH FOR "_DGDAY_" ***" G QUIT
- D WR
- G QUIT
- HEAD S DGPG=DGPG+1 W @IOF,!,DGHD,?35,"PRINTED: ",DGTIME,?72," PAGE: "_DGPG
- W !!,"NAME",?22,"PT ID",?38,"LEFT",?54,"LOCATION"
- W !,DGCL,!!,?10,"DIVISION: ",$S(DGDV="ZUNKNOWN":"UNKNOWN",1:DGDV),!
- Q
- WR S (DGU,DGDV,DGFL,DGP)=0
- F DGD=0:0 S DGDV=$O(^UTILITY($J,"DG",DGDV)) Q:DGDV=""!(DGU) S DGPG=0 D:DGFL RT Q:DGU D HEAD F M=0:0 S DGP=$O(^UTILITY($J,"DG",DGDV,DGP)) Q:DGP=""!(DGU) D WRCNT
- W ! Q
- WRCNT F DFN=0:0 S DFN=$O(^UTILITY($J,"DG",DGDV,DGP,DFN)) Q:'DFN!(DGU) S DGNO=^UTILITY($J,"DG",DGDV,DGP,DFN) D WR1 S DGFL=1
- Q
- WR1 I $Y+4>IOSL D:IOST?1"C-".E RT Q:DGU D HEAD
- W !,$E(DGP,1,20),?22,$P(DGNO,"^"),?38 S X=$P(DGNO,"^",2) W X W ?54,$P(DGNO,"^",3) Q
- RT Q:IOST'?1"C-".E
- F X=$Y:1:(IOSL-2) W !
- R !?22,"Enter <RET> to continue or ^ to Quit",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOASIH 2821 printed Feb 19, 2025@00:12:21 Page 2
- DGOASIH ;ALB/VAD - LIST OF PATIENTS ON ASIH ;Sep 27 1999
- +1 ;;5.3;Registration;**162,227**;Aug 13, 1993
- +2 ;
- +3 ; PATCH 5.3*227 ADDED SEP 27 1999 BY VAD
- +4 ; Rather than only allow for the entry of tomorrow's date, the
- +5 ; ability to enter any future date has been added. However, if
- +6 ; a future date is entered, then a warning message will display
- +7 ; stating that the report should be tasked to prevent the printing
- +8 ; of a negative report. Line EN3 has been split to allow for the
- +9 ; code for this patch to be added.
- +10 ;
- EN3 KILL TD,DGF
- SET %DT="AEXPT"
- SET %DT("A")="Enter date of ASIH: "
- DO ^%DT
- if Y'>0
- GOTO QUIT
- +1 ; *** Start of patched code inserted for 5.3*227 - VAD.
- +2 IF +Y>+DT
- Begin DoDot:1
- +3 WRITE !!?10,$CHAR(7),"You have entered a future date...to prevent the printing"
- +4 WRITE !?10,"of a negative report, remember to task this request for"
- +5 WRITE !?10,"the appropriate date."
- +6 SET DGU=0
- DO RT
- End DoDot:1
- if DGU
- GOTO QUIT
- +7 ; *** End of patched code.
- +8 ;
- +9 SET DGT=+Y
- SET DGT=$SELECT(DGT[".":DGT,1:DGT_".2400")
- +10 SET Y=DGT
- XECUTE ^DD("DD")
- SET DGDAY=$PIECE(Y,"@")
- SET DGHD="ASIH LIST FOR "_Y
- SET X1=DT
- SET X2=-30
- DO C^%DTC
- SET DGPG=0
- +11 SET DGVAR="DGT^DGPG^DGDAY^DGHD"
- SET DGPGM="START^DGOASIH"
- DO ZIS^DGUTQ
- IF 'POP
- USE IO
- DO START^DGOASIH
- QUIT KILL DGHD,DGST
- IF '$DATA(ZTQUEUED)
- DO CLOSE^DGUTQ
- QUIT1 KILL %,%I,%T,%DT,DFN,DG2,DGADM,DGCA,DGCD,DGCL,DGD,DGDAY,DGDV,DGFL,DGI,DGJ,DGLV,DGNO,DGP,DGPG,DGPGM,DGRT,DGSTART,DGT,DGTIME,DGTP,DGU,DGVAR,DGW,DGA,DGDAT,DGDFN,DGDT,DGIFN,DGNOW,DGTYP,DGX,DGY,POP,VA,VADAT,VADATE,VAERR,^UTILITY($JOB,"DG"),X,X1,X2,Y
- +1 KILL M,VAIP,VAIP("D")
- QUIT
- START DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- SET DGTIME=$$FMTE^XLFDT(Y,1)
- SET $PIECE(DGCL,"-",81)=""
- SET DGFL=0
- SET X1=DGT
- SET X2=-32
- DO C^%DTC
- SET DGSTART=X
- +1 DO NOW^%DTC
- SET DGNOW=%
- +2 SET DGA="^13^43^44^45^"
- +3 SET DGDAT=DGT
- SET DGST=0
- SET DGPG=0
- +4 FOR DGDT=DGSTART:0
- SET DGDT=$ORDER(^DGPM("AMV2",DGDT))
- if 'DGDT!(DGDT>DGDAT)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DGPM("AMV2",DGDT,DFN))
- if 'DFN
- QUIT
- FOR DGIFN=0:0
- SET DGIFN=$ORDER(^DGPM("AMV2",DGDT,DFN,DGIFN))
- if 'DGIFN
- QUIT
- SET DGASIH=1
- DO CK^DGPASS
- if DGFL
- QUIT
- +5 KILL DGASIH
- IF '$DATA(^UTILITY($JOB,"DG"))
- WRITE !!?8,"*** THERE ARE NO PATIENTS OUT ON ASIH FOR "_DGDAY_" ***"
- GOTO QUIT
- +6 DO WR
- +7 GOTO QUIT
- HEAD SET DGPG=DGPG+1
- WRITE @IOF,!,DGHD,?35,"PRINTED: ",DGTIME,?72," PAGE: "_DGPG
- +1 WRITE !!,"NAME",?22,"PT ID",?38,"LEFT",?54,"LOCATION"
- +2 WRITE !,DGCL,!!,?10,"DIVISION: ",$SELECT(DGDV="ZUNKNOWN":"UNKNOWN",1:DGDV),!
- +3 QUIT
- WR SET (DGU,DGDV,DGFL,DGP)=0
- +1 FOR DGD=0:0
- SET DGDV=$ORDER(^UTILITY($JOB,"DG",DGDV))
- if DGDV=""!(DGU)
- QUIT
- SET DGPG=0
- if DGFL
- DO RT
- if DGU
- QUIT
- DO HEAD
- FOR M=0:0
- SET DGP=$ORDER(^UTILITY($JOB,"DG",DGDV,DGP))
- if DGP=""!(DGU)
- QUIT
- DO WRCNT
- +2 WRITE !
- QUIT
- WRCNT FOR DFN=0:0
- SET DFN=$ORDER(^UTILITY($JOB,"DG",DGDV,DGP,DFN))
- if 'DFN!(DGU)
- QUIT
- SET DGNO=^UTILITY($JOB,"DG",DGDV,DGP,DFN)
- DO WR1
- SET DGFL=1
- +1 QUIT
- WR1 IF $Y+4>IOSL
- if IOST?1"C-".E
- DO RT
- if DGU
- QUIT
- DO HEAD
- +1 WRITE !,$EXTRACT(DGP,1,20),?22,$PIECE(DGNO,"^"),?38
- SET X=$PIECE(DGNO,"^",2)
- WRITE X
- WRITE ?54,$PIECE(DGNO,"^",3)
- QUIT
- RT if IOST'?1"C-".E
- QUIT
- +1 FOR X=$Y:1:(IOSL-2)
- WRITE !
- +2 READ !?22,"Enter <RET> to continue or ^ to Quit",X:DTIME
- if X["^"!('$TEST)
- SET DGU=1
- if DGU=1
- QUIT
- +3 QUIT