- DGJOPRT2 ;ALB/MAF - REPORTS CONTINUED ; AUG 30 1991@1000
- ;;5.3;Registration;**163,1015**;Aug 13, 1993;Build 21
- ;
- D HEAD F DGJ=0:0 S DGJTDV=$O(^UTILITY("VAS",$J,DGJTDV)) Q:DGJTDV']""!(DGU) D:DGJTF&(DGJTL="PAT"!(DGJTL="DAT")) RET Q:DGU D:DGJTF&(DGJTL="PAT"!(DGJTL="DAT")) HEAD D:DGJTL="PAT"!(DGJTL="DAT") HDR S DGJTF=1 D @(DGJTL) Q:DGU
- G:DGU QUIT I $D(^UTILITY("VAS",$J)) D RET G:DGU QUIT D ^DGJOPRT3
- QUIT G QUIT^DGJOPRT3
- SET S DGJTDV1=DGJTDV Q
- DIV S X=$O(^DG(40.8,"B",DGJTDV1,0)) I $D(^DG(40.8,+X,"DT")) S DGJTDEL=^("DT") W $P(DGJTDEL,"^",9),! Q
- Q
- DATE S DGJTX=$$FMTE^XLFDT(DGJTDT,"5DF"),DGJTX=$TR(DGJTX," ","0") W DGJTX K DGJTX Q
- PAT F DGJY=0:0 S DGJTPT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPT)) Q:DGJTPT']""!(DGU) D PAT1
- Q
- PAT1 F DFN=0:0 S DFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPT,DFN,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2
- Q
- PHY D:'DGJTFF HDR
- F DGJY=0:0 S DGJTPHY=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY)) Q:DGJTPHY']""!(DGU) D:DGJTFF RET Q:DGU D:DGJTFF HEAD,HDR D HDR1 S DGJTFF=1 F DGJJ=0:0 S DGJTPT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY,DGJTPT)) Q:DGJTPT']""!(DGU) D PHY1 Q:DGU
- Q
- PHY1 F DFN=0:0 S DFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTPHY,DGJTPT,DFN,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2 Q:DGU D PH
- Q
- DAT F DGJTDT=0:0 S DGJTDT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTDT)) Q:'DGJTDT F DGJY=0:0 S DGJTPT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTDT,DGJTPT)) Q:DGJTPT']""!(DGU) D DAT1
- Q
- DAT1 F DFN=0:0 S DFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTDT,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTDT,DGJTPT,DFN,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2
- Q
- SER D:'DGJTFF HDR
- F DGJY=0:0 S DGJTSV=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV)) Q:DGJTSV']""!(DGU) D:DGJTFF RET Q:DGU D:DGJTFF HEAD,HDR D HDR2 S DGJTFF=1 F DGJJ=0:0 S DGJTSP=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP)) Q:DGJTSP']""!(DGU) D HDR3,SER1 Q:DGU
- Q
- SER1 F DGJP=0:0 S DGJTPT=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT)) Q:DGJTPT']""!(DGU) D SER2
- Q
- SER2 F DFN=0:0 S DFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^UTILITY("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2 Q:DGU D SV
- Q
- PRT2 D RELP Q:DGU S DGJTNODE=^VAS(393,IFN,0)
- I DGJTL'="PHY" S DGJTPC=14 S DGJTPHY=$S($P(DGJTNODE,"^",DGJTPC)]""&($D(^VA(200,+$P(DGJTNODE,"^",DGJTPC),0))):$P(^(0),"^",1),1:"NOT SPECIFIED")
- I DGJTL="DAT" W ! D DATE W ?13
- I DGJTL'="DAT" W !
- W $E(DGJTPT,1,15)
- D PID^VADPT6 W:DGJTL="DAT" ?30 W:DGJTL'="DAT" ?18 W VA("BID")
- I DGJTL'="DAT" S DGJTDT=$P(DGJTNODE,"^",3) W ?26 D DATE
- I $P(DGJTNODE,"^",4)]"" S DGJTAD=$P(DGJTNODE,"^",4) I $D(^DGPM(DGJTAD,0)) S DGJTDIS=$P(^(0),"^",17) I $D(^DGPM(+DGJTDIS,0)) S DGJTTYP=$P(^(0),"^",4) W ?39,$S($D(^DG(405.1,+DGJTTYP,0)):$E($P(^(0),"^",1),1,12),1:"")
- W ?53,$S($P(DGJTNODE,"^",5)]""&($D(^SC(+$P(DGJTNODE,"^",5),0))):$E($P(^SC($P(DGJTNODE,"^",5),0),"^",1),1,13),1:"")
- S DFN=$P(DGJTNODE,"^",1) S RTE=DFN_";DPT(",RTYPE=1 D LATEST^RTUTL3
- W ?69,$E($P(RTDATA,"^",2),1,12)
- I DGJTL="PHY" D HD1^DGJOPRT3 Q
- W ?87,$E(DGJTPHY,1,15)
- W ?106,$S($P(DGJTNODE,"^",2)]""&($D(^VAS(393.3,+$P(DGJTNODE,"^",2),0))):$E($P(^VAS(393.3,$P(DGJTNODE,"^",2),0),"^",1),1,3),1:"")
- I DGJTDIR=2 W ?111,$S($P(DGJTNODE,"^",11)&($D(^DG(393.2,+$P(DGJTNODE,"^",11),0))):$E($P(^DG(393.2,$P(DGJTNODE,"^",11),0),"^",1),1,10),1:"")
- W ?125,$J(DGJTDL,4)
- Q
- HEAD D HEAD^DGJOPRT3 Q
- RET I DGJTL="PAT"!(DGJTL="DAT")&(IOST'?1"C-".E) G RET1
- Q:IOST'?1"C-".E
- RET1 F X=$Y:1:(IOSL-3) W !
- D DIV Q:IOST'?1"C-".E
- R ?22,"Enter <RET> to continue or ^ to QUIT ",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU S DGFLAG=1 Q
- RELP I $Y+8>IOSL I DGJTL="PAT"!(DGJTL="DAT") D RET Q:DGU D HEAD Q
- I $Y+8>IOSL D RET:(IOST?1"C-".E) Q:DGU D HEAD
- Q
- HDR W !?5,"DIVISION: ",DGJTDV Q
- HDR1 W !?6,"PHYSICIAN: ",DGJTPHY Q
- HDR2 W !?6,"SERVICE: ",DGJTSV Q
- HDR3 W !?7,"SPECIALTY: ",DGJTSP Q
- PH D PH^DGJOPRT3 Q
- SV D SV^DGJOPRT3 Q
- DGJOPRT2 ;ALB/MAF - REPORTS CONTINUED ; AUG 30 1991@1000
- +1 ;;5.3;Registration;**163,1015**;Aug 13, 1993;Build 21
- +2 ;
- +3 DO HEAD
- FOR DGJ=0:0
- SET DGJTDV=$ORDER(^UTILITY("VAS",$JOB,DGJTDV))
- IF DGJTDV']""!(DGU)
- QUIT
- IF DGJTF&(DGJTL="PAT"!(DGJTL="DAT"))
- DO RET
- IF DGU
- QUIT
- IF DGJTF&(DGJTL="PAT"!(DGJTL="DAT"))
- DO HEAD
- IF DGJTL="PAT"!(DGJTL="DAT")
- DO HDR
- SET DGJTF=1
- DO @(DGJTL)
- IF DGU
- QUIT
- +4 IF DGU
- GOTO QUIT
- IF $DATA(^UTILITY("VAS",$JOB))
- DO RET
- IF DGU
- GOTO QUIT
- DO ^DGJOPRT3
- QUIT GOTO QUIT^DGJOPRT3
- SET SET DGJTDV1=DGJTDV
- QUIT
- DIV SET X=$ORDER(^DG(40.8,"B",DGJTDV1,0))
- IF $DATA(^DG(40.8,+X,"DT"))
- SET DGJTDEL=^("DT")
- WRITE $PIECE(DGJTDEL,"^",9),!
- QUIT
- +1 QUIT
- DATE SET DGJTX=$$FMTE^XLFDT(DGJTDT,"5DF")
- SET DGJTX=$TRANSLATE(DGJTX," ","0")
- WRITE DGJTX
- KILL DGJTX
- QUIT
- PAT FOR DGJY=0:0
- SET DGJTPT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPT))
- IF DGJTPT']""!(DGU)
- QUIT
- DO PAT1
- +1 QUIT
- PAT1 FOR DFN=0:0
- SET DFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPT,DFN))
- IF 'DFN!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPT,DFN,IFN))
- IF 'IFN!(DGU)
- QUIT
- SET DGJTDL=^(IFN)
- DO SET
- IF $DATA(^VAS(393,IFN,0))
- DO PRT2
- +1 QUIT
- PHY IF 'DGJTFF
- DO HDR
- +1 FOR DGJY=0:0
- SET DGJTPHY=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY))
- IF DGJTPHY']""!(DGU)
- QUIT
- IF DGJTFF
- DO RET
- IF DGU
- QUIT
- IF DGJTFF
- DO HEAD
- DO HDR
- DO HDR1
- SET DGJTFF=1
- FOR DGJJ=0:0
- SET DGJTPT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT))
- IF DGJTPT']""!(DGU)
- QUIT
- DO PHY1
- IF DGU
- QUIT
- +2 QUIT
- PHY1 FOR DFN=0:0
- SET DFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT,DFN))
- IF 'DFN!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT,DFN,IFN))
- IF 'IFN!(DGU)
- QUIT
- SET DGJTDL=^(IFN)
- DO SET
- IF $DATA(^VAS(393,IFN,0))
- DO PRT2
- IF DGU
- QUIT
- DO PH
- +1 QUIT
- DAT FOR DGJTDT=0:0
- SET DGJTDT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTDT))
- IF 'DGJTDT
- QUIT
- FOR DGJY=0:0
- SET DGJTPT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTDT,DGJTPT))
- IF DGJTPT']""!(DGU)
- QUIT
- DO DAT1
- +1 QUIT
- DAT1 FOR DFN=0:0
- SET DFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTDT,DGJTPT,DFN))
- IF 'DFN!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTDT,DGJTPT,DFN,IFN))
- IF 'IFN!(DGU)
- QUIT
- SET DGJTDL=^(IFN)
- DO SET
- IF $DATA(^VAS(393,IFN,0))
- DO PRT2
- +1 QUIT
- SER IF 'DGJTFF
- DO HDR
- +1 FOR DGJY=0:0
- SET DGJTSV=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV))
- IF DGJTSV']""!(DGU)
- QUIT
- IF DGJTFF
- DO RET
- IF DGU
- QUIT
- IF DGJTFF
- DO HEAD
- DO HDR
- DO HDR2
- SET DGJTFF=1
- FOR DGJJ=0:0
- SET DGJTSP=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP))
- IF DGJTSP']""!(DGU)
- QUIT
- DO HDR3
- DO SER1
- IF DGU
- QUIT
- +2 QUIT
- SER1 FOR DGJP=0:0
- SET DGJTPT=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT))
- IF DGJTPT']""!(DGU)
- QUIT
- DO SER2
- +1 QUIT
- SER2 FOR DFN=0:0
- SET DFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN))
- IF 'DFN!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^UTILITY("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN,IFN))
- IF 'IFN!(DGU)
- QUIT
- SET DGJTDL=^(IFN)
- DO SET
- IF $DATA(^VAS(393,IFN,0))
- DO PRT2
- IF DGU
- QUIT
- DO SV
- +1 QUIT
- PRT2 DO RELP
- IF DGU
- QUIT
- SET DGJTNODE=^VAS(393,IFN,0)
- +1 IF DGJTL'="PHY"
- SET DGJTPC=14
- SET DGJTPHY=$SELECT($PIECE(DGJTNODE,"^",DGJTPC)]""&($DATA(^VA(200,+$PIECE(DGJTNODE,"^",DGJTPC),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED")
- +2 IF DGJTL="DAT"
- WRITE !
- DO DATE
- WRITE ?13
- +3 IF DGJTL'="DAT"
- WRITE !
- +4 WRITE $EXTRACT(DGJTPT,1,15)
- +5 DO PID^VADPT6
- IF DGJTL="DAT"
- WRITE ?30
- IF DGJTL'="DAT"
- WRITE ?18
- WRITE VA("BID")
- +6 IF DGJTL'="DAT"
- SET DGJTDT=$PIECE(DGJTNODE,"^",3)
- WRITE ?26
- DO DATE
- +7 IF $PIECE(DGJTNODE,"^",4)]""
- SET DGJTAD=$PIECE(DGJTNODE,"^",4)
- IF $DATA(^DGPM(DGJTAD,0))
- SET DGJTDIS=$PIECE(^(0),"^",17)
- IF $DATA(^DGPM(+DGJTDIS,0))
- SET DGJTTYP=$PIECE(^(0),"^",4)
- WRITE ?39,$SELECT($DATA(^DG(405.1,+DGJTTYP,0)):$EXTRACT($PIECE(^(0),"^",1),1,12),1:"")
- +8 WRITE ?53,$SELECT($PIECE(DGJTNODE,"^",5)]""&($DATA(^SC(+$PIECE(DGJTNODE,"^",5),0))):$EXTRACT($PIECE(^SC($PIECE(DGJTNODE,"^",5),0),"^",1),1,13),1:"")
- +9 SET DFN=$PIECE(DGJTNODE,"^",1)
- SET RTE=DFN_";DPT("
- SET RTYPE=1
- DO LATEST^RTUTL3
- +10 WRITE ?69,$EXTRACT($PIECE(RTDATA,"^",2),1,12)
- +11 IF DGJTL="PHY"
- DO HD1^DGJOPRT3
- QUIT
- +12 WRITE ?87,$EXTRACT(DGJTPHY,1,15)
- +13 WRITE ?106,$SELECT($PIECE(DGJTNODE,"^",2)]""&($DATA(^VAS(393.3,+$PIECE(DGJTNODE,"^",2),0))):$EXTRACT($PIECE(^VAS(393.3,$PIECE(DGJTNODE,"^",2),0),"^",1),1,3),1:"")
- +14 IF DGJTDIR=2
- WRITE ?111,$SELECT($PIECE(DGJTNODE,"^",11)&($DATA(^DG(393.2,+$PIECE(DGJTNODE,"^",11),0))):$EXTRACT($PIECE(^DG(393.2,$PIECE(DGJTNODE,"^",11),0),"^",1),1,10),1:"")
- +15 WRITE ?125,$JUSTIFY(DGJTDL,4)
- +16 QUIT
- HEAD DO HEAD^DGJOPRT3
- QUIT
- RET IF DGJTL="PAT"!(DGJTL="DAT")&(IOST'?1"C-".E)
- GOTO RET1
- +1 IF IOST'?1"C-".E
- QUIT
- RET1 FOR X=$Y:1:(IOSL-3)
- WRITE !
- +1 DO DIV
- IF IOST'?1"C-".E
- QUIT
- +2 READ ?22,"Enter <RET> to continue or ^ to QUIT ",X:DTIME
- IF X["^"!('$TEST)
- SET DGU=1
- IF DGU
- QUIT
- SET DGFLAG=1
- QUIT
- RELP IF $Y+8>IOSL
- IF DGJTL="PAT"!(DGJTL="DAT")
- DO RET
- IF DGU
- QUIT
- DO HEAD
- QUIT
- +1 IF $Y+8>IOSL
- IF (IOST?1"C-".E)
- DO RET
- IF DGU
- QUIT
- DO HEAD
- +2 QUIT
- HDR WRITE !?5,"DIVISION: ",DGJTDV
- QUIT
- HDR1 WRITE !?6,"PHYSICIAN: ",DGJTPHY
- QUIT
- HDR2 WRITE !?6,"SERVICE: ",DGJTSV
- QUIT
- HDR3 WRITE !?7,"SPECIALTY: ",DGJTSP
- QUIT
- PH DO PH^DGJOPRT3
- QUIT
- SV DO SV^DGJOPRT3
- QUIT
