DGJTEE1 ;MAF/ALB - CONT. ENTER EDIT DEFICIENCIES - JUNE 1992
;;1.0;Incomplete Records Tracking;;Jun 25, 2001
LOOP F DGJTCDIS=0:0 S DGJTCDIS=$O(^TMP("DGJ",$J,DGJTCDIS)) Q:DGJTCDIS']"" F DGJTYP=0:0 S DGJTYP=$O(^TMP("DGJ",$J,DGJTCDIS,DGJTYP)) Q:'DGJTYP F IFN=0:0 S IFN=$O(^TMP("DGJ",$J,DGJTCDIS,DGJTYP,IFN)) Q:'IFN D LOOP2
Q
LOOP2 Q:'$D(^VAS(393,IFN,0)) S DGJTADN=^VAS(393,IFN,0) Q:$P(DGJTDV,"^",1)'=$P(DGJTADN,"^",6) Q:DGJTAIFN'=$P(DGJTADN,"^",4) I '$D(DGJTDLT) D STATCK I $D(DGJFL1) K DGJFL1 Q
I $D(DGJTDLT),'$D(DGJVIEW),$O(^VAS(393.3,"B","DISCHARGE SUMMARY",0))=DGJTYP Q
I DGJTAIFN]"" D SETG1 Q
Q
LOWER(X) ;
N Y,C,Z,I
S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
F C=" ",",","/" S I=0 F S I=$F(Y,C,I) Q:'I S Y=$E(Y,1,I-1)_$TR($E(Y,I),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(Y,I+1,999)
Q Y
SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
; S := string
; V := destination
; X := @ col X
; L := # of chars
;
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
;
STATCK ;Status check (complete)
S X=$P(DGJTADN,"^",11),DGJX=$P(DGJTADN,"^",6),DGJX=$G(^DG(40.8,DGJX,"DT"))
I $D(DGJTCOM) D
.I X=CM Q
.I $P(DGJX,"^",3)=1,X=RV Q
.I $P(DGJX,"^",3)=0,X=SN Q
.S DGJFL1=1
.Q
E D ;not complete
.I X=CM S DGJFL1=1 Q
.I $P(DGJX,"^",3)=1,X=RV S DGJFL1=1 Q
.I $P(DGJX,"^",3)=0,X=SN S DGJFL1=1 Q
Q
HDR S X=""
S X=$$SETSTR(" PATIENT: ",X,1,11)
S X=$$SETSTR($E($P($G(^DPT(DGJTPT,0)),"^",1),1,20),X,12,20)
S X=$$SETSTR("PT ID: ",X,40,7)
S X=$$SETSTR(DGJID,X,48,12)
S VALMHDR(1)=X
S X=""
S X=$$SETSTR("ADMISSION: ",X,1,11)
I $D(DGJTOA),+$G(DGJTX) S X=$$SETSTR($$FTIME^VALM1($P(DGJTOA(DGJTX),"^",2)),X,12,18)
I '$D(DGJTOA) S X=$$SETSTR("OUTPATIENT",X,12,10)
S VALMHDR(2)=X
Q
EXP ; -- expand
N DGJVALM,DGJAT,VALMY,DIR
S VALMBCK=""
D SEL^VALM2 G ENQ:'$O(VALMY(0)) S DGJVALM=0
D FULL^VALM1 S VALMBCK="R"
F S DGJVALM=$O(VALMY(DGJVALM)) Q:'DGJVALM D
.D FULL^VALM1
.S DGJAT=$G(^TMP("DGJIDX",$J,DGJVALM))
.W !!,^TMP("DGJDEF",$J,+DGJAT,0),!
.S (DA,DGJDFNO)=+$P(DGJAT,U,2),DIC="^VAS(393,",DR="0" D EN^DIQ,PAUSE^VALM1 I Y=""!(Y=0) S VALMBCK="R" Q
.I $D(DGJTSEDT) D EXP2 Q
.S DGJTYP=$P(^VAS(393.3,$P(^VAS(393,DA,0),"^",2),0),"^",1) I "^OP REPORT^DISCHARGE SUMMARY^INTERIM SUMMARY^"[DGJTYP S DGJTYP=$O(^VAS(393.3,"B",DGJTYP,0)) S DGJTAIFN=$P(^VAS(393,DA,0),"^",4),DGJTEDT="1^"_DA D EXP1
S VALMBCK="R"
ENQ Q
EXP1 D INIT3^DGJTEE2 S VALMBG=1,VALMBCK="R"
Q
EXP2 ;TS EDIT
Q:'$D(^VAS(393,DA,0)) I $P(^VAS(393,DA,0),"^",2)'=$O(^VAS(393.3,"B","DISCHARGE SUMMARY",0)) D TSEDIT,EVDT^DGJTEE G TSQ
S (X,DGJTNUM)=2 S DGJTNO="^^^"_DGJTAIFN D CK^DGJTVW1
Q
TSEDIT S DIE="^VAS(393,",DA=DA,DR=".07;.09;.1" D ^DIE Q
TSQ S VALMBG=1,VALMBCK="R" Q
PAT1 ; -- change pat
D FULL^VALM1 S VALMBG=1,VALMBCK="R"
K X,DGJCPSR1,DGJCPSR2 I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2)
S DGJCPDFN=DFN,DGJCPNOD=DGJTNODE S:$D(DGJTSR1) DGJCPSR1=DGJTSR1 S:$D(DGJTSR2) DGJCPSR2=DGJTSR2
I $G(DGJTSR1)=1 S DGJCPTX=DGJTX
K DGJTSR1,DGJTSR2
D PAT^DGJTEE
I Y<0!(DGJTFG=1)!('$D(DGJTSR1)&('$D(DGJTSR2))) S:DGJTAIFN]"" DGJTX=DGJCPTX,DGJTOA(DGJTX)=DGJTAIFN_"^"_$P(^DGPM(DGJTAIFN,0),"^",1) S (DFN,DGJTPT)=DGJCPDFN,DGJTNODE=DGJCPNOD D G PATQ
.S:$D(DGJCPSR1) DGJTSR1=DGJCPSR1 S:$D(DGJCPSR2) DGJTSR2=DGJCPSR2
.W !!,*7,"Patient has not been changed."
.W ! S DIR(0)="E" D ^DIR K DIR
.S DGJTFG=0 S VALMBCK="R"
D HDR^DGJTEE
PATQ Q
SETG1 I $D(DGJTREC) I "^OP REPORT^DISCHARGE SUMMARY^INTERIM SUMMARY^"'[($P(^VAS(393.3,$P(DGJTADN,"^",2),0),"^")) Q
S DGJTCAT=$P(^VAS(393.3,DGJTYP,0),"^",6)
S DGJCNT1=DGJCNT1+1
I '$D(DGJCAT(DGJTCAT)) D CATSET
S X="",DGJCNT=DGJCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR(DGJCNT1,X,1,3)
S DGJVAL=$P(DGJTADN,"^",2)
S X=$$SETSTR($$LOWER($P($G(^VAS(393.3,+DGJVAL,0)),"^")),X,+$S($D(DGJTREC):TC,1:DC),+$S($D(DGJTREC):TW,1:DW))
S X=$$SETSTR($$LOWER($P($G(^VA(200,+$P(DGJTADN,"^",14),0)),"^")),X,+PC,+PW)
S X=$$SETSTR($$LOWER($P($G(^DG(393.2,+$P(DGJTADN,"^",11),0)),"^")),X,+SC,+SW)
S DGX=$P($G(^VAS(393.3,+DGJVAL,0)),"^",6),DGX=$P($G(^VAS(393.41,+DGX,0)),"^") I DGX]"" S X=$$SETSTR($$LOWER(DGX),X,+CC,+CW)
I $P(DGJTADN,"^",3)]"" S DGX=$P(DGJTADN,"^",3) I DGX]"" S X=$$SETSTR($$LOWER($$FTIME^VALM1(DGX)),X,+EC,+EW)
S ^TMP("DGJDEF",$J,DGJCNT,0)=X,^TMP("DGJDEF",$J,"IDX",VALMCNT,DGJCNT1)=""
S ^TMP("DGJIDX",$J,DGJCNT1)=VALMCNT_"^"_IFN
Q
CATSET ;CATEGORY HEADING
S DGJCNT=DGJCNT+1,VALMCNT=VALMCNT+1
S DGJCAT(DGJTCAT)=DGJCNT
S X=""
S X=$$SETSTR(" ",X,1,3) D TMP
S X="",DGJCNT=DGJCNT+1,VALMCNT=VALMCNT+1
S DGJVAL=$P(^VAS(393.41,DGJTCAT,0),"^",1)
S DGJVAL1=$L(DGJVAL) S DGJVAL1=(80-DGJVAL1)/2 S DGJVAL1=DGJVAL1\1 S X=$$SETSTR(" ",X,1,DGJVAL1)
S X=$$SETSTR(DGJVAL,X,DGJVAL1,25) D TMP
S X="",DGJCNT=DGJCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR(" ",X,1,3) D TMP
Q
TMP S ^TMP("DGJDEF",$J,DGJCNT,0)=X,^TMP("DGJDEF",$J,"IDX",VALMCNT,DGJCNT1)=""
S ^TMP("DGJIDX",$J,DGJCNT1)=VALMCNT_"^"_IFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGJTEE1 5006 printed Dec 13, 2024@02:00:51 Page 2
DGJTEE1 ;MAF/ALB - CONT. ENTER EDIT DEFICIENCIES - JUNE 1992
+1 ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
LOOP FOR DGJTCDIS=0:0
SET DGJTCDIS=$ORDER(^TMP("DGJ",$JOB,DGJTCDIS))
if DGJTCDIS']""
QUIT
FOR DGJTYP=0:0
SET DGJTYP=$ORDER(^TMP("DGJ",$JOB,DGJTCDIS,DGJTYP))
if 'DGJTYP
QUIT
FOR IFN=0:0
SET IFN=$ORDER(^TMP("DGJ",$JOB,DGJTCDIS,DGJTYP,IFN))
if 'IFN
QUIT
DO LOOP2
+1 QUIT
LOOP2 if '$DATA(^VAS(393,IFN,0))
QUIT
SET DGJTADN=^VAS(393,IFN,0)
if $PIECE(DGJTDV,"^",1)'=$PIECE(DGJTADN,"^",6)
QUIT
if DGJTAIFN'=$PIECE(DGJTADN,"^",4)
QUIT
IF '$DATA(DGJTDLT)
DO STATCK
IF $DATA(DGJFL1)
KILL DGJFL1
QUIT
+1 IF $DATA(DGJTDLT)
IF '$DATA(DGJVIEW)
IF $ORDER(^VAS(393.3,"B","DISCHARGE SUMMARY",0))=DGJTYP
QUIT
+2 IF DGJTAIFN]""
DO SETG1
QUIT
+3 QUIT
LOWER(X) ;
+1 NEW Y,C,Z,I
+2 SET Y=$EXTRACT(X)_$TRANSLATE($EXTRACT(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
+3 FOR C=" ",",","/"
SET I=0
FOR
SET I=$FIND(Y,C,I)
if 'I
QUIT
SET Y=$EXTRACT(Y,1,I-1)_$TRANSLATE($EXTRACT(Y,I),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(Y,I+1,999)
+4 QUIT Y
SETSTR(S,V,X,L) ; -- insert text(S) into variable(V)
+1 ; S := string
+2 ; V := destination
+3 ; X := @ col X
+4 ; L := # of chars
+5 ;
+6 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
+7 ;
STATCK ;Status check (complete)
+1 SET X=$PIECE(DGJTADN,"^",11)
SET DGJX=$PIECE(DGJTADN,"^",6)
SET DGJX=$GET(^DG(40.8,DGJX,"DT"))
+2 IF $DATA(DGJTCOM)
Begin DoDot:1
+3 IF X=CM
QUIT
+4 IF $PIECE(DGJX,"^",3)=1
IF X=RV
QUIT
+5 IF $PIECE(DGJX,"^",3)=0
IF X=SN
QUIT
+6 SET DGJFL1=1
+7 QUIT
End DoDot:1
+8 ;not complete
IF '$TEST
Begin DoDot:1
+9 IF X=CM
SET DGJFL1=1
QUIT
+10 IF $PIECE(DGJX,"^",3)=1
IF X=RV
SET DGJFL1=1
QUIT
+11 IF $PIECE(DGJX,"^",3)=0
IF X=SN
SET DGJFL1=1
QUIT
End DoDot:1
+12 QUIT
HDR SET X=""
+1 SET X=$$SETSTR(" PATIENT: ",X,1,11)
+2 SET X=$$SETSTR($EXTRACT($PIECE($GET(^DPT(DGJTPT,0)),"^",1),1,20),X,12,20)
+3 SET X=$$SETSTR("PT ID: ",X,40,7)
+4 SET X=$$SETSTR(DGJID,X,48,12)
+5 SET VALMHDR(1)=X
+6 SET X=""
+7 SET X=$$SETSTR("ADMISSION: ",X,1,11)
+8 IF $DATA(DGJTOA)
IF +$GET(DGJTX)
SET X=$$SETSTR($$FTIME^VALM1($PIECE(DGJTOA(DGJTX),"^",2)),X,12,18)
+9 IF '$DATA(DGJTOA)
SET X=$$SETSTR("OUTPATIENT",X,12,10)
+10 SET VALMHDR(2)=X
+11 QUIT
EXP ; -- expand
+1 NEW DGJVALM,DGJAT,VALMY,DIR
+2 SET VALMBCK=""
+3 DO SEL^VALM2
if '$ORDER(VALMY(0))
GOTO ENQ
SET DGJVALM=0
+4 DO FULL^VALM1
SET VALMBCK="R"
+5 FOR
SET DGJVALM=$ORDER(VALMY(DGJVALM))
if 'DGJVALM
QUIT
Begin DoDot:1
+6 DO FULL^VALM1
+7 SET DGJAT=$GET(^TMP("DGJIDX",$JOB,DGJVALM))
+8 WRITE !!,^TMP("DGJDEF",$JOB,+DGJAT,0),!
+9 SET (DA,DGJDFNO)=+$PIECE(DGJAT,U,2)
SET DIC="^VAS(393,"
SET DR="0"
DO EN^DIQ
DO PAUSE^VALM1
IF Y=""!(Y=0)
SET VALMBCK="R"
QUIT
+10 IF $DATA(DGJTSEDT)
DO EXP2
QUIT
+11 SET DGJTYP=$PIECE(^VAS(393.3,$PIECE(^VAS(393,DA,0),"^",2),0),"^",1)
IF "^OP REPORT^DISCHARGE SUMMARY^INTERIM SUMMARY^"[DGJTYP
SET DGJTYP=$ORDER(^VAS(393.3,"B",DGJTYP,0))
SET DGJTAIFN=$PIECE(^VAS(393,DA,0),"^",4)
SET DGJTEDT="1^"_DA
DO EXP1
End DoDot:1
+12 SET VALMBCK="R"
ENQ QUIT
EXP1 DO INIT3^DGJTEE2
SET VALMBG=1
SET VALMBCK="R"
+1 QUIT
EXP2 ;TS EDIT
+1 if '$DATA(^VAS(393,DA,0))
QUIT
IF $PIECE(^VAS(393,DA,0),"^",2)'=$ORDER(^VAS(393.3,"B","DISCHARGE SUMMARY",0))
DO TSEDIT
DO EVDT^DGJTEE
GOTO TSQ
+2 SET (X,DGJTNUM)=2
SET DGJTNO="^^^"_DGJTAIFN
DO CK^DGJTVW1
+3 QUIT
TSEDIT SET DIE="^VAS(393,"
SET DA=DA
SET DR=".07;.09;.1"
DO ^DIE
QUIT
TSQ SET VALMBG=1
SET VALMBCK="R"
QUIT
PAT1 ; -- change pat
+1 DO FULL^VALM1
SET VALMBG=1
SET VALMBCK="R"
+2 KILL X,DGJCPSR1,DGJCPSR2
IF $DATA(XQORNOD(0))
SET X=$PIECE($PIECE(XQORNOD(0),U,4),"=",2)
+3 SET DGJCPDFN=DFN
SET DGJCPNOD=DGJTNODE
if $DATA(DGJTSR1)
SET DGJCPSR1=DGJTSR1
if $DATA(DGJTSR2)
SET DGJCPSR2=DGJTSR2
+4 IF $GET(DGJTSR1)=1
SET DGJCPTX=DGJTX
+5 KILL DGJTSR1,DGJTSR2
+6 DO PAT^DGJTEE
+7 IF Y<0!(DGJTFG=1)!('$DATA(DGJTSR1)&('$DATA(DGJTSR2)))
if DGJTAIFN]""
SET DGJTX=DGJCPTX
SET DGJTOA(DGJTX)=DGJTAIFN_"^"_$PIECE(^DGPM(DGJTAIFN,0),"^",1)
SET (DFN,DGJTPT)=DGJCPDFN
SET DGJTNODE=DGJCPNOD
Begin DoDot:1
+8 if $DATA(DGJCPSR1)
SET DGJTSR1=DGJCPSR1
if $DATA(DGJCPSR2)
SET DGJTSR2=DGJCPSR2
+9 WRITE !!,*7,"Patient has not been changed."
+10 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
+11 SET DGJTFG=0
SET VALMBCK="R"
End DoDot:1
GOTO PATQ
+12 DO HDR^DGJTEE
PATQ QUIT
SETG1 IF $DATA(DGJTREC)
IF "^OP REPORT^DISCHARGE SUMMARY^INTERIM SUMMARY^"'[($PIECE(^VAS(393.3,$PIECE(DGJTADN,"^",2),0),"^"))
QUIT
+1 SET DGJTCAT=$PIECE(^VAS(393.3,DGJTYP,0),"^",6)
+2 SET DGJCNT1=DGJCNT1+1
+3 IF '$DATA(DGJCAT(DGJTCAT))
DO CATSET
+4 SET X=""
SET DGJCNT=DGJCNT+1
SET VALMCNT=VALMCNT+1
+5 SET X=$$SETSTR(DGJCNT1,X,1,3)
+6 SET DGJVAL=$PIECE(DGJTADN,"^",2)
+7 SET X=$$SETSTR($$LOWER($PIECE($GET(^VAS(393.3,+DGJVAL,0)),"^")),X,+$SELECT($DATA(DGJTREC):TC,1:DC),+$SELECT($DATA(DGJTREC):TW,1:DW))
+8 SET X=$$SETSTR($$LOWER($PIECE($GET(^VA(200,+$PIECE(DGJTADN,"^",14),0)),"^")),X,+PC,+PW)
+9 SET X=$$SETSTR($$LOWER($PIECE($GET(^DG(393.2,+$PIECE(DGJTADN,"^",11),0)),"^")),X,+SC,+SW)
+10 SET DGX=$PIECE($GET(^VAS(393.3,+DGJVAL,0)),"^",6)
SET DGX=$PIECE($GET(^VAS(393.41,+DGX,0)),"^")
IF DGX]""
SET X=$$SETSTR($$LOWER(DGX),X,+CC,+CW)
+11 IF $PIECE(DGJTADN,"^",3)]""
SET DGX=$PIECE(DGJTADN,"^",3)
IF DGX]""
SET X=$$SETSTR($$LOWER($$FTIME^VALM1(DGX)),X,+EC,+EW)
+12 SET ^TMP("DGJDEF",$JOB,DGJCNT,0)=X
SET ^TMP("DGJDEF",$JOB,"IDX",VALMCNT,DGJCNT1)=""
+13 SET ^TMP("DGJIDX",$JOB,DGJCNT1)=VALMCNT_"^"_IFN
+14 QUIT
CATSET ;CATEGORY HEADING
+1 SET DGJCNT=DGJCNT+1
SET VALMCNT=VALMCNT+1
+2 SET DGJCAT(DGJTCAT)=DGJCNT
+3 SET X=""
+4 SET X=$$SETSTR(" ",X,1,3)
DO TMP
+5 SET X=""
SET DGJCNT=DGJCNT+1
SET VALMCNT=VALMCNT+1
+6 SET DGJVAL=$PIECE(^VAS(393.41,DGJTCAT,0),"^",1)
+7 SET DGJVAL1=$LENGTH(DGJVAL)
SET DGJVAL1=(80-DGJVAL1)/2
SET DGJVAL1=DGJVAL1\1
SET X=$$SETSTR(" ",X,1,DGJVAL1)
+8 SET X=$$SETSTR(DGJVAL,X,DGJVAL1,25)
DO TMP
+9 SET X=""
SET DGJCNT=DGJCNT+1
SET VALMCNT=VALMCNT+1
+10 SET X=$$SETSTR(" ",X,1,3)
DO TMP
+11 QUIT
TMP SET ^TMP("DGJDEF",$JOB,DGJCNT,0)=X
SET ^TMP("DGJDEF",$JOB,"IDX",VALMCNT,DGJCNT1)=""
+1 SET ^TMP("DGJIDX",$JOB,DGJCNT1)=VALMCNT_"^"_IFN
+2 QUIT
