- DGJPDEF2 ;ALB/MAF - PHYSICIAN DEFICIENCY PRINT ROUTINE (CONT) ; NOV 10 1992@300
- ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- D HEAD F DGJ=0:0 S DGJTDV=$O(^TMP("VAS",$J,DGJTDV)) Q:DGJTDV']""!(DGU) S DGJTF=1 D @(DGJTL) Q:DGU
- G:DGU QUIT I DGJTLPG'=1,$D(^TMP("VAS",$J)) D RET G:DGU QUIT D ^DGJPDEF3
- F X=$Y:1:(IOSL-3) W !
- D DIV
- QUIT G QUIT^DGJPDEF
- F X=$Y:1:(IOSL-3) W ! D DIV
- HD1 W ?88,$J($P(DGJTDL,"^",2),7)
- W ?97,$J($P(DGJTDL,"^",3),7)
- W ?106,$J($P(DGJTDL,"^",4),7)
- W ?116 S X=$P(DGJTDL,"^",2)+$P(DGJTDL,"^",3)+$P(DGJTDL,"^",4)+$P(DGJTDL,"^",1) W $J(X,7)
- W ?128 S X=$S(X-30'>0:0,1:X-30) W $J(X,4)
- Q
- SET S DGJTDV1=DGJTDV,DFN=DGJTDL 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
- DATE1 S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0") W X Q
- PHY D:'DGJTFF HDR
- F DGJY=0:0 S DGJTPHY=$O(^TMP("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(^TMP("VAS",$J,DGJTDV,DGJTPHY,DGJTPT)) Q:DGJTPT']""!(DGU) D PHY1 Q:DGU
- Q
- PHY1 F DGJADM=-1:0 S DGJADM=$O(^TMP("VAS",$J,DGJTDV,DGJTPHY,DGJTPT,DGJADM)) Q:DGJADM']""!(DGU) F IFN=0:0 S IFN=$O(^TMP("VAS",$J,DGJTDV,DGJTPHY,DGJTPT,DGJADM,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2 Q:DGU
- Q
- SER D:'DGJTFF HDR
- F DGJY=0:0 S DGJTSV=$O(^TMP("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(^TMP("VAS",$J,DGJTDV,DGJTSV,DGJTSP)) Q:DGJTSP']""!(DGU) D HDR3,SER1 Q:DGU
- Q
- PAT D:'DGJTFF HDR
- F DGJY=0:0 S DGJTPT=$O(^TMP("VAS",$J,DGJTDV,DGJTPT)) Q:DGJTPT']""!(DGU) D:DGJTFF RET Q:DGU D:DGJTFF HEAD,HDR D HDR4 S DGJTFF=1 F DGJADM=-1:0 S DGJADM=$O(^TMP("VAS",$J,DGJTDV,DGJTPT,DGJADM)) Q:DGJADM']""!(DGU) D PAT1 Q:DGU
- Q
- PAT1 F DGJJ=0:0 S DGJTPHY=$O(^TMP("VAS",$J,DGJTDV,DGJTPT,DGJADM,DGJTPHY)) Q:DGJTPHY']""!(DGU) F IFN=0:0 S IFN=$O(^TMP("VAS",$J,DGJTDV,DGJTPT,DGJADM,DGJTPHY,IFN)) Q:'IFN!(DGU) S DGJTDL=^(IFN) D SET I $D(^VAS(393,IFN,0)) D PRT2 Q:DGU
- Q
- SER1 F DGJP=0:0 S DGJTPT=$O(^TMP("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT)) Q:DGJTPT']""!(DGU) D SER2
- Q
- SER2 F DFN=0:0 S DFN=$O(^TMP("VAS",$J,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN)) Q:'DFN!(DGU) F IFN=0:0 S IFN=$O(^TMP("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
- Q
- PRT2 D RELP Q:DGU S DGJTNODE=^VAS(393,IFN,0)
- I DGJTL="PAT" S X="",X=$S($P(DGJTPHY,"^",2)]"":$E($P($G(^VA(200,$P(DGJTPHY,"^",2),0)),"^",1),1,20),1:"NOT SPECIFIED") W !,$S(X]"":X,1:"NOT SPECIFIED")
- I DGJTL="PHY" W !,$E($P(^DPT($P(DGJTPT,"^",2),0),"^",1),1,20)
- I DGJTL="SER" W !,$E($P(^DPT($P(DGJTPT,"^",2),0),"^",1),1,16)
- D PID^VADPT6 W:DGJTL="SER" ?19 W:DGJTL'="SER" ?23 W VA("BID")
- S DGJTDT=$S($D(^DGPM(+$P(DGJTNODE,"^",4),0)):$P(^DGPM(+$P(DGJTNODE,"^",4),0),"^",1),1:"OUTPATIENT") W:DGJTL="SER" ?27 W:DGJTL'="SER" ?31 D:DGJTDT]""&(DGJTDT'="OUTPATIENT") DATE I DGJTDT="OUTPATIENT" W DGJTDT
- W:DGJTL="SER" ?40 W:DGJTL'="SER" ?44 S X=$P(^VAS(393,IFN,0),"^",2) W $S($D(^VAS(393.3,+X,0)):$E($P(^VAS(393.3,+X,0),"^",1),1,10),1:"NOT SPECIF")
- S X=$P(^VAS(393,IFN,0),"^",12),X=$S(X]""&($D(^VA(200,+X,0))):$P(^VA(200,X,0),"^",1),1:"NOT SPECIFIED") W:DGJTL="SER" ?57,$E(X,1,10)
- S X=IFN I X]"",$D(^VAS(393,+X,0)) S X=$P(^VAS(393,+X,0),"^",3) W ?70 S X=$$FMTE^XLFDT(X,"5DF") S:X]"" X=$TR(X," ","0") W X
- W ?82 S X=$P(DGJTNODE,"^",11) W $S($D(^DG(393.2,+X,0)):$E($P(^DG(393.2,X,0),"^",1),1,10),1:"")
- S DFN=$P(DGJTNODE,"^",1) S RTE=DFN_";DPT(",RTYPE=$$RECTYP^DGJOPRT1(DGJTNODE) D LATEST^RTUTL3
- W ?95,$E($P(RTDATA,"^",2),1,10),?107,$E($P(RTDATA,"^",3),1,10),?121 S X="" S X=$P(RTDATA,"^",4) D:RTDATA]"" DATE1 Q
- HEAD D HEAD^DGJPDEF3 Q
- RET 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 D RET:(IOST?1"C-".E) Q:DGU D HEAD
- Q
- HDR W !?5,"DIVISION: ",$S($D(^DG(40.8,+$P(DGJTDV,"^",2),0)):$P(^DG(40.8,$P(DGJTDV,"^",2),0),"^",1),1:"NOT SPECIFIED") Q
- HDR1 W !?6,"PHYSICIAN: ",$S($P(DGJTPHY,"^",2)]""&($D(^VA(200,+$P(DGJTPHY,"^",2),0))):$P(^VA(200,$P(DGJTPHY,"^",2),0),"^",1),1:"NOT SPECIFIED") Q
- HDR2 W !?6,"SERVICE: ",$S($P(DGJTSV,"^",2)]"":$P(^DG(393.1,$P(DGJTSV,"^",2),0),"^",1),1:"NOT SPECIFIED") Q
- HDR3 W !?7,"SPECIALTY: ",$S($P(DGJTSP,"^",2)]"":$P(^DIC(45.7,$P(DGJTSP,"^",2),0),"^",1),1:"NOT SPECIFIED") Q
- HDR4 W !?6,"PATIENT: ",$P(^DPT($P(DGJTPT,"^",2),0),"^",1) Q
- SV D SV^DGJPDEF3 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGJPDEF2 4589 printed Apr 23, 2025@18:15:12 Page 2
- DGJPDEF2 ;ALB/MAF - PHYSICIAN DEFICIENCY PRINT ROUTINE (CONT) ; NOV 10 1992@300
- +1 ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- +2 DO HEAD
- FOR DGJ=0:0
- SET DGJTDV=$ORDER(^TMP("VAS",$JOB,DGJTDV))
- if DGJTDV']""!(DGU)
- QUIT
- SET DGJTF=1
- DO @(DGJTL)
- if DGU
- QUIT
- +3 if DGU
- GOTO QUIT
- IF DGJTLPG'=1
- IF $DATA(^TMP("VAS",$JOB))
- DO RET
- if DGU
- GOTO QUIT
- DO ^DGJPDEF3
- +4 FOR X=$Y:1:(IOSL-3)
- WRITE !
- +5 DO DIV
- QUIT GOTO QUIT^DGJPDEF
- +1 FOR X=$Y:1:(IOSL-3)
- WRITE !
- DO DIV
- HD1 WRITE ?88,$JUSTIFY($PIECE(DGJTDL,"^",2),7)
- +1 WRITE ?97,$JUSTIFY($PIECE(DGJTDL,"^",3),7)
- +2 WRITE ?106,$JUSTIFY($PIECE(DGJTDL,"^",4),7)
- +3 WRITE ?116
- SET X=$PIECE(DGJTDL,"^",2)+$PIECE(DGJTDL,"^",3)+$PIECE(DGJTDL,"^",4)+$PIECE(DGJTDL,"^",1)
- WRITE $JUSTIFY(X,7)
- +4 WRITE ?128
- SET X=$SELECT(X-30'>0:0,1:X-30)
- WRITE $JUSTIFY(X,4)
- +5 QUIT
- SET SET DGJTDV1=DGJTDV
- SET DFN=DGJTDL
- 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
- DATE1 SET X=$$FMTE^XLFDT(X,"5DF")
- SET X=$TRANSLATE(X," ","0")
- WRITE X
- QUIT
- PHY if 'DGJTFF
- DO HDR
- +1 FOR DGJY=0:0
- SET DGJTPHY=$ORDER(^TMP("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(^TMP("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT))
- if DGJTPT']""!(DGU)
- QUIT
- DO PHY1
- if DGU
- QUIT
- +2 QUIT
- PHY1 FOR DGJADM=-1:0
- SET DGJADM=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT,DGJADM))
- if DGJADM']""!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTPHY,DGJTPT,DGJADM,IFN))
- if 'IFN!(DGU)
- QUIT
- SET DGJTDL=^(IFN)
- DO SET
- IF $DATA(^VAS(393,IFN,0))
- DO PRT2
- if DGU
- QUIT
- +1 QUIT
- SER if 'DGJTFF
- DO HDR
- +1 FOR DGJY=0:0
- SET DGJTSV=$ORDER(^TMP("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(^TMP("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP))
- if DGJTSP']""!(DGU)
- QUIT
- DO HDR3
- DO SER1
- if DGU
- QUIT
- +2 QUIT
- PAT if 'DGJTFF
- DO HDR
- +1 FOR DGJY=0:0
- SET DGJTPT=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTPT))
- if DGJTPT']""!(DGU)
- QUIT
- if DGJTFF
- DO RET
- if DGU
- QUIT
- if DGJTFF
- DO HEAD
- DO HDR
- DO HDR4
- SET DGJTFF=1
- FOR DGJADM=-1:0
- SET DGJADM=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTPT,DGJADM))
- if DGJADM']""!(DGU)
- QUIT
- DO PAT1
- if DGU
- QUIT
- +2 QUIT
- PAT1 FOR DGJJ=0:0
- SET DGJTPHY=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTPT,DGJADM,DGJTPHY))
- if DGJTPHY']""!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTPT,DGJADM,DGJTPHY,IFN))
- if 'IFN!(DGU)
- QUIT
- SET DGJTDL=^(IFN)
- DO SET
- IF $DATA(^VAS(393,IFN,0))
- DO PRT2
- if DGU
- QUIT
- +1 QUIT
- SER1 FOR DGJP=0:0
- SET DGJTPT=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT))
- if DGJTPT']""!(DGU)
- QUIT
- DO SER2
- +1 QUIT
- SER2 FOR DFN=0:0
- SET DFN=$ORDER(^TMP("VAS",$JOB,DGJTDV,DGJTSV,DGJTSP,DGJTPT,DFN))
- if 'DFN!(DGU)
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^TMP("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
- +1 QUIT
- PRT2 DO RELP
- if DGU
- QUIT
- SET DGJTNODE=^VAS(393,IFN,0)
- +1 IF DGJTL="PAT"
- SET X=""
- SET X=$SELECT($PIECE(DGJTPHY,"^",2)]"":$EXTRACT($PIECE($GET(^VA(200,$PIECE(DGJTPHY,"^",2),0)),"^",1),1,20),1:"NOT SPECIFIED")
- WRITE !,$SELECT(X]"":X,1:"NOT SPECIFIED")
- +2 IF DGJTL="PHY"
- WRITE !,$EXTRACT($PIECE(^DPT($PIECE(DGJTPT,"^",2),0),"^",1),1,20)
- +3 IF DGJTL="SER"
- WRITE !,$EXTRACT($PIECE(^DPT($PIECE(DGJTPT,"^",2),0),"^",1),1,16)
- +4 DO PID^VADPT6
- if DGJTL="SER"
- WRITE ?19
- if DGJTL'="SER"
- WRITE ?23
- WRITE VA("BID")
- +5 SET DGJTDT=$SELECT($DATA(^DGPM(+$PIECE(DGJTNODE,"^",4),0)):$PIECE(^DGPM(+$PIECE(DGJTNODE,"^",4),0),"^",1),1:"OUTPATIENT")
- if DGJTL="SER"
- WRITE ?27
- if DGJTL'="SER"
- WRITE ?31
- if DGJTDT]""&(DGJTDT'="OUTPATIENT")
- DO DATE
- IF DGJTDT="OUTPATIENT"
- WRITE DGJTDT
- +6 if DGJTL="SER"
- WRITE ?40
- if DGJTL'="SER"
- WRITE ?44
- SET X=$PIECE(^VAS(393,IFN,0),"^",2)
- WRITE $SELECT($DATA(^VAS(393.3,+X,0)):$EXTRACT($PIECE(^VAS(393.3,+X,0),"^",1),1,10),1:"NOT SPECIF")
- +7 SET X=$PIECE(^VAS(393,IFN,0),"^",12)
- SET X=$SELECT(X]""&($DATA(^VA(200,+X,0))):$PIECE(^VA(200,X,0),"^",1),1:"NOT SPECIFIED")
- if DGJTL="SER"
- WRITE ?57,$EXTRACT(X,1,10)
- +8 SET X=IFN
- IF X]""
- IF $DATA(^VAS(393,+X,0))
- SET X=$PIECE(^VAS(393,+X,0),"^",3)
- WRITE ?70
- SET X=$$FMTE^XLFDT(X,"5DF")
- if X]""
- SET X=$TRANSLATE(X," ","0")
- WRITE X
- +9 WRITE ?82
- SET X=$PIECE(DGJTNODE,"^",11)
- WRITE $SELECT($DATA(^DG(393.2,+X,0)):$EXTRACT($PIECE(^DG(393.2,X,0),"^",1),1,10),1:"")
- +10 SET DFN=$PIECE(DGJTNODE,"^",1)
- SET RTE=DFN_";DPT("
- SET RTYPE=$$RECTYP^DGJOPRT1(DGJTNODE)
- DO LATEST^RTUTL3
- +11 WRITE ?95,$EXTRACT($PIECE(RTDATA,"^",2),1,10),?107,$EXTRACT($PIECE(RTDATA,"^",3),1,10),?121
- SET X=""
- SET X=$PIECE(RTDATA,"^",4)
- if RTDATA]""
- DO DATE1
- QUIT
- HEAD DO HEAD^DGJPDEF3
- QUIT
- RET 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 (IOST?1"C-".E)
- DO RET
- if DGU
- QUIT
- DO HEAD
- +1 QUIT
- HDR WRITE !?5,"DIVISION: ",$SELECT($DATA(^DG(40.8,+$PIECE(DGJTDV,"^",2),0)):$PIECE(^DG(40.8,$PIECE(DGJTDV,"^",2),0),"^",1),1:"NOT SPECIFIED")
- QUIT
- HDR1 WRITE !?6,"PHYSICIAN: ",$SELECT($PIECE(DGJTPHY,"^",2)]""&($DATA(^VA(200,+$PIECE(DGJTPHY,"^",2),0))):$PIECE(^VA(200,$PIECE(DGJTPHY,"^",2),0),"^",1),1:"NOT SPECIFIED")
- QUIT
- HDR2 WRITE !?6,"SERVICE: ",$SELECT($PIECE(DGJTSV,"^",2)]"":$PIECE(^DG(393.1,$PIECE(DGJTSV,"^",2),0),"^",1),1:"NOT SPECIFIED")
- QUIT
- HDR3 WRITE !?7,"SPECIALTY: ",$SELECT($PIECE(DGJTSP,"^",2)]"":$PIECE(^DIC(45.7,$PIECE(DGJTSP,"^",2),0),"^",1),1:"NOT SPECIFIED")
- QUIT
- HDR4 WRITE !?6,"PATIENT: ",$PIECE(^DPT($PIECE(DGJTPT,"^",2),0),"^",1)
- QUIT
- SV DO SV^DGJPDEF3
- QUIT
