- DGJPDEF1 ;ALB/MAF - PHYSICIAN DEFICIENCY PRINT ROUTINE (CONT) ; NOV 10 1992@300
- ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- ;;MAS VERSION 5.2;
- I $D(DGJTMUL),DGJTMUL D DIVISION^VAUTOMA G:Y=-1 QUIT
- I 'DGJTMUL S DGJTDV=$O(^DG(40.8,0))
- D @(DGJTL) G:Y=-1 QUIT
- D DAT^DGJPDEF G:Y=-1 QUIT
- S VAUTVB="VAUTY",DIC="^VAS(393.3,",VAUTSTR="Deficiency",VAUTNI=2 D FIRST^VAUTOMA G QUIT:Y=-1
- D ASK1^DGJPDEF G:Y=-1 QUIT
- W !!,*7,"This output requires 132 column output",!
- D NOW^%DTC S Y=$E(%,1,12) S VADAT("W")=Y D ^VADATE S DGJTDAT=VADATE("E")
- S DGVAR="DGJDSC^DGJTDV^DGJTDIR^DGJTDAT^DGJTLPG^DGJTSTAT^DGJTCK^DGJTFL^DGJTMESS^DGJTSR^DGJTSR1^DGJTMUL^DGJTL^DGJTBG^DGJTEND^VAUTD#^VAUTN#^VAUTT#^VAUTY#",DGPGM="START^DGJPDEF1" D ZIS^DGJUTQ I 'POP U IO G START^DGJPDEF1
- G QUIT
- START S (DGJTPAG,DGJTDV1)=0 F IFN=0:0 S IFN=$O(^VAS(393,IFN)) Q:'IFN S DGJTNODE=^VAS(393,IFN,0) D CK
- I DGJTLPG=1!(DGJTLPG=3),$D(^TMP("VAS",$J)) S (DGJ,DGJTF,DGJTFF,DGJY,DGJTDV,DGJTDT,DGJTSV,DGJTSP,DGJTPHY,DGJTPT,DGU,DFN,IFN)=0,$P(DGJTLN,"=",133)="" G ^DGJPDEF2
- I DGJTLPG=2,$D(^TMP("VAS",$J)) S (DGJ,DGJTF,DGJTFF,DGJY,DGJTDV,DGJTDT,DGJTSV,DGJTSP,DGJTPHY,DGJTPT,DGU,DFN,IFN)=0,$P(DGJTLN,"=",133)="" G ^DGJPDEF3
- I '$D(^TMP("VAS",$J)) W !!,"NO RECORDS"
- QUIT G QUIT^DGJPDEF
- SSP ;find service and specialty
- N CA S (DGJT,CA)=$S($P(DGJTNODE,"^",2)]"":+$P(DGJTNODE,"^",2),1:"") Q:DGJT']""
- S:'$D(^DGPM(+DGJT,0)) DGJTQF=1 Q:'$D(^DGPM(+DGJT,0)) S DGJT=$O(^DGPM("ATS",DFN,DGJT,0)) S DGJT=$O(^(+DGJT,0)),DGJT=$O(^(+DGJT,0)),DGJT=$S($D(^DGPM(+DGJT,0)):^(0),1:"")
- D WARD^DGJTUTL
- I +X S DGJTWARD=+X,X=$S($D(^DIC(42,+X,0)):$P(^(0),"^",11),1:""),DGJTDIV=X
- S DGJTP=$S($D(^DG(40.8,+DGJTDIV,"DT")):^("DT"),1:"")
- S DGJTSV=$S(DGJTWARD]"":$P(^DIC(42,+DGJTWARD,0),"^",3),1:"") I DGJTSV]"" S DGJTSV=$O(^DG(393.1,"AC",DGJTSV,0)) S:(VAUTN=0)&('$D(VAUTN(DGJTSV))) DGJTQF=1 Q:DGJTQF S DGJTSV=$S($D(^DG(393.1,+DGJTSV,0)):$P(^DG(393.1,+DGJTSV,0),"^",1),1:"NONE")
- I DGJTSV']"" S:DGJTSV']"" DGJTSV=0 S DGJTSV=$S($D(^DG(393.1,"AC",DGJTSV)):$O(^(DGJTSV,0)),1:"") I DGJTSV']"" S DGJTSV=$O(^DG(393.1,"AC",0,0))
- S DGJTSP=$P(DGJT,"^",9) S:VAUTT=0&('$D(VAUTT(+DGJTSP))) DGJTQF=1 Q:DGJTQF S DGJTSP=$S($D(^DIC(45.7,+DGJTSP,0)):$P(^DIC(45.7,DGJTSP,0),"^",1),1:"NOT SPECIFIED")
- Q
- CK S DGJTQF=0 I $D(VAUTD),'VAUTD Q:$P(DGJTNODE,"^",6)']"" I '$D(VAUTD(+$P(DGJTNODE,"^",6))) Q
- I $D(DGJTDV),$P(DGJTNODE,"^",6)]"" I $P(DGJTNODE,"^",6)'=DGJTDV Q
- S X=$P(DGJTNODE,"^",6),X1=$G(^DG(40.8,+X,"DT")),X1=$P(X1,"^",3),X2=$P(DGJTNODE,"^",11) I X1=0&(X2=$O(^DG(393.2,"B","SIGNED NO REVIEW",0))) K X1,X2,X3 Q
- I X1=1&(X2=$O(^DG(393.2,"B","REVIEWED",0))) K X1,X2,X3 Q
- I X2=$O(^DG(393.2,"B","COMPLETED",0)) K X1,X2,X3 Q
- K X1,X2,X3
- I DGJTSR1=1,$P(DGJTNODE,"^",4)']"" Q
- I DGJTSR1=2,$P(DGJTNODE,"^",4)]"" Q
- I $D(VAUTY),'VAUTY I '$D(VAUTY(+$P(DGJTNODE,"^",2))) Q
- I $P(DGJTNODE,"^",3)<DGJTBG!($P(DGJTNODE,"^",3)>DGJTEND) Q
- I DGJTL="PHY",$D(VAUTN),'VAUTN I '$D(VAUTN(+$P(DGJTNODE,"^",14))) Q
- I DGJTL="PAT",$D(VAUTN),'VAUTN S X=$P(DGJTNODE,"^",1) I '$D(VAUTN(+X)) Q
- I DGJDSC,DGJTSR1'=2 S X=$P(DGJTNODE,"^",4) I X]"" I $D(^DGPM(X,0)) S X=$P(^DGPM(X,0),"^",17) I X']"" S X=$P(DGJTNODE,"^",2),X=$G(^VAS(393.3,+X,0)) I X]"" S X=$P(X,"^",6) I X=$O(^VAS(393.41,"B","SUMMARY",0)) Q
- S DGJTDIV=$P(DGJTNODE,"^",6),DGJTDVN=$E($S($P(DGJTNODE,"^",6)]""&($D(^DG(40.8,+$P(DGJTNODE,"^",6),0))):$P(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_$P(DGJTNODE,"^",6) I '$D(DGJTOT(DGJTDVN)) S DGJTOT(DGJTDVN)=0
- S DFN=+DGJTNODE S DGJTPT=$E($S('$D(^DPT(+DFN,0)):"UNDEFINED",1:$P(^DPT(+DFN,0),"^",1)),1,10)_"^"_DFN
- I DGJTL="PHY" S DGJTPHY=$E($S($P(DGJTNODE,"^",14)]""&($D(^VA(200,+$P(DGJTNODE,"^",14),0))):$P(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_$P(DGJTNODE,"^",14) S ^TMP("VAS",$J,DGJTDVN,DGJTPHY,DGJTPT,+$P(DGJTNODE,"^",4),IFN)=DFN Q
- I DGJTL="PAT" S DGJTPHY=$E($S($P(DGJTNODE,"^",14)]""&($D(^VA(200,+$P(DGJTNODE,"^",14),0))):$P(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_$P(DGJTNODE,"^",14) S ^TMP("VAS",$J,DGJTDVN,DGJTPT,+$P(DGJTNODE,"^",4),DGJTPHY,IFN)=DFN Q
- I DGJTL="SER" S X=$P(DGJTNODE,"^",8) S DGJTSV=$S(X]""&($D(^DG(393.1,+$P(DGJTNODE,"^",8),0))):$P(^(0),"^",1),1:"NOT SPECIFIED"),DGJTSP=$S($P(DGJTNODE,"^",7)]""&($D(^DIC(45.7,+$P(DGJTNODE,"^",7),0))):$P(^(0),"^",1),1:"NOT SPECIFIED")
- S X=$P(DGJTNODE,"^",8) I X]"" Q:VAUTN=0&('$D(VAUTN(+X))) S DGJTSV=$E($S(X]""&($D(^DG(393.1,+X,0))):$P(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_+X
- S X=$P(DGJTNODE,"^",7) I X]"" Q:VAUTT=0&('$D(VAUTT(+X))) S DGJTSP=$E($S(X]""&($D(^DIC(45.7,+X,0))):$P(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_+X
- Q:DGJTQF
- I DGJTL="SER" S ^TMP("VAS",$J,DGJTDVN,DGJTSV,DGJTSP,DGJTPT,DFN,IFN)=DFN Q
- Q
- PHY S VAUTVB="VAUTN",DIC="^VA(200,",VAUTSTR="Physician",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 DGJFL=1 Q:DGJFL
- Q
- PAT S VAUTNI=2 D PATIENT^VAUTOMA
- Q
- SER S VAUTVB="VAUTN",DIC="^DG(393.1,",VAUTSTR="Service",VAUTNI=2 D FIRST^VAUTOMA Q:Y=-1
- S VAUTVB="VAUTT",DIC="^DIC(45.7,",VAUTSTR="Specialty",VAUTNI=2 D FIRST^VAUTOMA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGJPDEF1 4949 printed Feb 18, 2025@23:27:06 Page 2
- DGJPDEF1 ;ALB/MAF - PHYSICIAN DEFICIENCY PRINT ROUTINE (CONT) ; NOV 10 1992@300
- +1 ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- +2 ;;MAS VERSION 5.2;
- +3 IF $DATA(DGJTMUL)
- IF DGJTMUL
- DO DIVISION^VAUTOMA
- if Y=-1
- GOTO QUIT
- +4 IF 'DGJTMUL
- SET DGJTDV=$ORDER(^DG(40.8,0))
- +5 DO @(DGJTL)
- if Y=-1
- GOTO QUIT
- +6 DO DAT^DGJPDEF
- if Y=-1
- GOTO QUIT
- +7 SET VAUTVB="VAUTY"
- SET DIC="^VAS(393.3,"
- SET VAUTSTR="Deficiency"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- if Y=-1
- GOTO QUIT
- +8 DO ASK1^DGJPDEF
- if Y=-1
- GOTO QUIT
- +9 WRITE !!,*7,"This output requires 132 column output",!
- +10 DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- SET VADAT("W")=Y
- DO ^VADATE
- SET DGJTDAT=VADATE("E")
- +11 SET DGVAR="DGJDSC^DGJTDV^DGJTDIR^DGJTDAT^DGJTLPG^DGJTSTAT^DGJTCK^DGJTFL^DGJTMESS^DGJTSR^DGJTSR1^DGJTMUL^DGJTL^DGJTBG^DGJTEND^VAUTD#^VAUTN#^VAUTT#^VAUTY#"
- SET DGPGM="START^DGJPDEF1"
- DO ZIS^DGJUTQ
- IF 'POP
- USE IO
- GOTO START^DGJPDEF1
- +12 GOTO QUIT
- START SET (DGJTPAG,DGJTDV1)=0
- FOR IFN=0:0
- SET IFN=$ORDER(^VAS(393,IFN))
- if 'IFN
- QUIT
- SET DGJTNODE=^VAS(393,IFN,0)
- DO CK
- +1 IF DGJTLPG=1!(DGJTLPG=3)
- IF $DATA(^TMP("VAS",$JOB))
- SET (DGJ,DGJTF,DGJTFF,DGJY,DGJTDV,DGJTDT,DGJTSV,DGJTSP,DGJTPHY,DGJTPT,DGU,DFN,IFN)=0
- SET $PIECE(DGJTLN,"=",133)=""
- GOTO ^DGJPDEF2
- +2 IF DGJTLPG=2
- IF $DATA(^TMP("VAS",$JOB))
- SET (DGJ,DGJTF,DGJTFF,DGJY,DGJTDV,DGJTDT,DGJTSV,DGJTSP,DGJTPHY,DGJTPT,DGU,DFN,IFN)=0
- SET $PIECE(DGJTLN,"=",133)=""
- GOTO ^DGJPDEF3
- +3 IF '$DATA(^TMP("VAS",$JOB))
- WRITE !!,"NO RECORDS"
- QUIT GOTO QUIT^DGJPDEF
- SSP ;find service and specialty
- +1 NEW CA
- SET (DGJT,CA)=$SELECT($PIECE(DGJTNODE,"^",2)]"":+$PIECE(DGJTNODE,"^",2),1:"")
- if DGJT']""
- QUIT
- +2 if '$DATA(^DGPM(+DGJT,0))
- SET DGJTQF=1
- if '$DATA(^DGPM(+DGJT,0))
- QUIT
- SET DGJT=$ORDER(^DGPM("ATS",DFN,DGJT,0))
- SET DGJT=$ORDER(^(+DGJT,0))
- SET DGJT=$ORDER(^(+DGJT,0))
- SET DGJT=$SELECT($DATA(^DGPM(+DGJT,0)):^(0),1:"")
- +3 DO WARD^DGJTUTL
- +4 IF +X
- SET DGJTWARD=+X
- SET X=$SELECT($DATA(^DIC(42,+X,0)):$PIECE(^(0),"^",11),1:"")
- SET DGJTDIV=X
- +5 SET DGJTP=$SELECT($DATA(^DG(40.8,+DGJTDIV,"DT")):^("DT"),1:"")
- +6 SET DGJTSV=$SELECT(DGJTWARD]"":$PIECE(^DIC(42,+DGJTWARD,0),"^",3),1:"")
- IF DGJTSV]""
- SET DGJTSV=$ORDER(^DG(393.1,"AC",DGJTSV,0))
- if (VAUTN=0)&('$DATA(VAUTN(DGJTSV)))
- SET DGJTQF=1
- if DGJTQF
- QUIT
- SET DGJTSV=$SELECT($DATA(^DG(393.1,+DGJTSV,0)):$PIECE(^DG(393.1,+DGJTSV,0),"^",1),1:"NONE")
- +7 IF DGJTSV']""
- if DGJTSV']""
- SET DGJTSV=0
- SET DGJTSV=$SELECT($DATA(^DG(393.1,"AC",DGJTSV)):$ORDER(^(DGJTSV,0)),1:"")
- IF DGJTSV']""
- SET DGJTSV=$ORDER(^DG(393.1,"AC",0,0))
- +8 SET DGJTSP=$PIECE(DGJT,"^",9)
- if VAUTT=0&('$DATA(VAUTT(+DGJTSP)))
- SET DGJTQF=1
- if DGJTQF
- QUIT
- SET DGJTSP=$SELECT($DATA(^DIC(45.7,+DGJTSP,0)):$PIECE(^DIC(45.7,DGJTSP,0),"^",1),1:"NOT SPECIFIED")
- +9 QUIT
- CK SET DGJTQF=0
- IF $DATA(VAUTD)
- IF 'VAUTD
- if $PIECE(DGJTNODE,"^",6)']""
- QUIT
- IF '$DATA(VAUTD(+$PIECE(DGJTNODE,"^",6)))
- QUIT
- +1 IF $DATA(DGJTDV)
- IF $PIECE(DGJTNODE,"^",6)]""
- IF $PIECE(DGJTNODE,"^",6)'=DGJTDV
- QUIT
- +2 SET X=$PIECE(DGJTNODE,"^",6)
- SET X1=$GET(^DG(40.8,+X,"DT"))
- SET X1=$PIECE(X1,"^",3)
- SET X2=$PIECE(DGJTNODE,"^",11)
- IF X1=0&(X2=$ORDER(^DG(393.2,"B","SIGNED NO REVIEW",0)))
- KILL X1,X2,X3
- QUIT
- +3 IF X1=1&(X2=$ORDER(^DG(393.2,"B","REVIEWED",0)))
- KILL X1,X2,X3
- QUIT
- +4 IF X2=$ORDER(^DG(393.2,"B","COMPLETED",0))
- KILL X1,X2,X3
- QUIT
- +5 KILL X1,X2,X3
- +6 IF DGJTSR1=1
- IF $PIECE(DGJTNODE,"^",4)']""
- QUIT
- +7 IF DGJTSR1=2
- IF $PIECE(DGJTNODE,"^",4)]""
- QUIT
- +8 IF $DATA(VAUTY)
- IF 'VAUTY
- IF '$DATA(VAUTY(+$PIECE(DGJTNODE,"^",2)))
- QUIT
- +9 IF $PIECE(DGJTNODE,"^",3)<DGJTBG!($PIECE(DGJTNODE,"^",3)>DGJTEND)
- QUIT
- +10 IF DGJTL="PHY"
- IF $DATA(VAUTN)
- IF 'VAUTN
- IF '$DATA(VAUTN(+$PIECE(DGJTNODE,"^",14)))
- QUIT
- +11 IF DGJTL="PAT"
- IF $DATA(VAUTN)
- IF 'VAUTN
- SET X=$PIECE(DGJTNODE,"^",1)
- IF '$DATA(VAUTN(+X))
- QUIT
- +12 IF DGJDSC
- IF DGJTSR1'=2
- SET X=$PIECE(DGJTNODE,"^",4)
- IF X]""
- IF $DATA(^DGPM(X,0))
- SET X=$PIECE(^DGPM(X,0),"^",17)
- IF X']""
- SET X=$PIECE(DGJTNODE,"^",2)
- SET X=$GET(^VAS(393.3,+X,0))
- IF X]""
- SET X=$PIECE(X,"^",6)
- IF X=$ORDER(^VAS(393.41,"B","SUMMARY",0))
- QUIT
- +13 SET DGJTDIV=$PIECE(DGJTNODE,"^",6)
- SET DGJTDVN=$EXTRACT($SELECT($PIECE(DGJTNODE,"^",6)]""&($DATA(^DG(40.8,+$PIECE(DGJTNODE,"^",6),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_$PIECE(DGJTNODE,"^",6)
- IF '$DATA(DGJTOT(DGJTDVN))
- SET DGJTOT(DGJTDVN)=0
- +14 SET DFN=+DGJTNODE
- SET DGJTPT=$EXTRACT($SELECT('$DATA(^DPT(+DFN,0)):"UNDEFINED",1:$PIECE(^DPT(+DFN,0),"^",1)),1,10)_"^"_DFN
- +15 IF DGJTL="PHY"
- SET DGJTPHY=$EXTRACT($SELECT($PIECE(DGJTNODE,"^",14)]""&($DATA(^VA(200,+$PIECE(DGJTNODE,"^",14),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_$PIECE(DGJTNODE,"^",14)
- SET ^TMP("VAS",$JOB,DGJTDVN,DGJTPHY,DGJTPT,+$PIECE(DGJTNODE,"^",4),IFN)=DFN
- QUIT
- +16 IF DGJTL="PAT"
- SET DGJTPHY=$EXTRACT($SELECT($PIECE(DGJTNODE,"^",14)]""&($DATA(^VA(200,+$PIECE(DGJTNODE,"^",14),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_$PIECE(DGJTNODE,"^",14)
- SET ^TMP("VAS",$JOB,DGJTDVN,DGJTPT,+$PIECE(DGJTNODE,"^",4),DGJTPHY,IFN)=DFN
- QUIT
- +17 IF DGJTL="SER"
- SET X=$PIECE(DGJTNODE,"^",8)
- SET DGJTSV=$SELECT(X]""&($DATA(^DG(393.1,+$PIECE(DGJTNODE,"^",8),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED")
- SET DGJTSP=$SELECT($PIECE(DGJTNODE,"^",7)]""&($DATA(^DIC(45.7,+$PIECE(DGJTNODE,"^",7),0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED")
- +18 SET X=$PIECE(DGJTNODE,"^",8)
- IF X]""
- if VAUTN=0&('$DATA(VAUTN(+X)))
- QUIT
- SET DGJTSV=$EXTRACT($SELECT(X]""&($DATA(^DG(393.1,+X,0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_+X
- +19 SET X=$PIECE(DGJTNODE,"^",7)
- IF X]""
- if VAUTT=0&('$DATA(VAUTT(+X)))
- QUIT
- SET DGJTSP=$EXTRACT($SELECT(X]""&($DATA(^DIC(45.7,+X,0))):$PIECE(^(0),"^",1),1:"NOT SPECIFIED"),1,10)_"^"_+X
- +20 if DGJTQF
- QUIT
- +21 IF DGJTL="SER"
- SET ^TMP("VAS",$JOB,DGJTDVN,DGJTSV,DGJTSP,DGJTPT,DFN,IFN)=DFN
- QUIT
- +22 QUIT
- PHY SET VAUTVB="VAUTN"
- SET DIC="^VA(200,"
- SET VAUTSTR="Physician"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- if Y=-1
- SET DGJFL=1
- if DGJFL
- QUIT
- +1 QUIT
- PAT SET VAUTNI=2
- DO PATIENT^VAUTOMA
- +1 QUIT
- SER SET VAUTVB="VAUTN"
- SET DIC="^DG(393.1,"
- SET VAUTSTR="Service"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- if Y=-1
- QUIT
- +1 SET VAUTVB="VAUTT"
- SET DIC="^DIC(45.7,"
- SET VAUTSTR="Specialty"
- SET VAUTNI=2
- DO FIRST^VAUTOMA
- +2 QUIT
