DGJPDEF1 ;ALB/MAF - PHYSICIAN DEFICIENCY PRINT ROUTINE (CONT) ; NOV 10 1992@300
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
;;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^DGUTQ 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
DGJPDEF1 ;ALB/MAF - PHYSICIAN DEFICIENCY PRINT ROUTINE (CONT) ; NOV 10 1992@300
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
+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^DGUTQ
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
