- DGJTUTL ;ALB/MIR - ZSECUTABLE HELP FOR EVENT DATE IN INCOMPLETE RECORD FILE ; 04 JAN 91
- ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- N DFN,I,J,OK,PTF S DFN=+^VAS(393,DA,0)
- D WARN
- ;
- W !,"Choose from:"
- F I=0:0 S I=$O(^UTILITY("DGJTADM",$J,I)) Q:'I S Y=+^DGPM(I,0) X ^DD("DD") W !?5,Y
- ;
- PTF ;Check to make sure PTF exists and it is not closed
- S OK=$S('$D(^DGPT(+PTF)):0,$D(^DGP(45.84,+PTF)):0,1:1)
- Q
- PHYSRTRG S DGJTEST=$P(^VAS(393,D0,0),"^",11) S X=$S(DGJTEST=$O(^DG(393.2,"B","TRANSCRIBED",0)):0,DGJTEST=$O(^DG(393.2,"B","SIGNED",0)):0,DGJTEST=$O(^DG(393.2,"B","REVIEWED",0)):0,1:1) K DGJTEST Q
- LESS48 ;Checking for discharge summary less than 48 hours.
- I $D(^VAS(393,DA,"DT")),$P(^("DT"),"^",1)]"" S X=0 Q
- S (DGJTX4,X1)=$P(^DGPM(+$P(DGJTNO,"^",4),0),"^",1),DGJTX3=+$P(DGJTNO,"^",3) S X2=2 D C^%DTC I DGJTX3<X&($P(DGJTNO,"^",3)>DGJTX4) D ASK K DGJTX3,DGJTX4
- Q
- ASK W !!,"Will this Discharge Summary <48 hrs need to be dictated? "
- S %=2 D YN^DICN I '% W !,"ENTER:",!?10,"Y for YES",!?10,"N for NO",!?10,"^ to EXIT" G ASK
- S X=$S(%=2:1,%=-1:"-1",1:0)
- Q
- TS D FULL^VALM1 D EXP^DGJTEE1 G TSQ
- TSQ D EVDT^DGJTEE S VALMBG=1,VALMBCK="R" Q
- WARN K ^UTILITY("DGJTADM",$J)
- S DGJTCNT=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I S IFN=$O(^(I,0)) I $D(^DGPM(IFN,0)),($P(^(0),"^",2)=1) S DGJTCNT=DGJTCNT+1,^UTILITY("DGJTADM",$J,DGJTCNT,IFN)=""
- I '$D(^UTILITY("DGJTADM",$J)) W !!,*7," Patient has no admissions on file in this facility",! Q
- K OK,I,PTF
- Q
- ;
- ;
- WR ;write node from delinquent records file
- N X,Y
- S X=$P(DGJT,"^",2)
- W $S(X]""&($D(^VAS(393.3,+X,0))):$P(^VAS(393.3,+X,0),"^",1),1:"UNKNOWN DEFICIENCY")
- S Y=$P(DGJT,"^",3) I Y]"" X ^DD("DD") W ?45,Y
- Q
- ;
- ;
- WARD ; -- find last ward for event driver
- ; input CA = ifn of cors adm
- N IDT,MVT,M
- S X=""
- F IDT=0:0 S IDT=$O(^DGPM("APMV",DFN,CA,IDT)) Q:'IDT F MVT=0:0 S MVT=$O(^DGPM("APMV",DFN,CA,IDT,MVT)) Q:'MVT I $D(^DGPM(MVT,0)) S M=^(0) I "^13^43^44^45^"'[(U_$P(M,U,18)_U),$D(^DIC(42,+$P(M,U,6),0)) S X=+$P(M,U,6) G WARDQ
- WARDQ Q
- PHYDEF ;Cross-reference on the Date Transcribed,10.03; Transcribed By,10.04
- ; Date Signed,10.05; Signed By,10.06
- ;to update the Physician for Deficiency field (#.14)
- ;in the Incomplete Records Tracking file (#393)
- N DGJX,DGJTNOD,DGJTDV,DGJTDN,DGJTPD,DGJNDT
- S DGJTNOD=$G(^VAS(393,DA,0)),DGJTDV=$P(DGJTNOD,"^",6)
- S DGJTDV=$G(^DG(40.8,DGJTDV,"DT"))
- I $D(DGJATTD) I $P(DGJTNOD,"^",11)=$O(^DG(393.2,"B","TRANSCRIBED",0))&($P(DGJTDV,"^",10)="A")!($P(DGJTNOD,"^",11)=$O(^DG(393.2,"B","SIGNED",0))&($P(DGJTDV,"^",4)="A")) S DGJX=$P(DGJTNOD,"^",10) D SET K DGJATTD Q
- S DGJTPD=$P(DGJTNOD,"^",14)
- S DGJNDT=$G(^VAS(393,DA,"DT"))
- I $D(DGJFDIC) D K DGJFDIC Q
- .S DGJX=$S($P(DGJNDT,"^",2)]""&($P(DGJNDT,"^",1)]""):$P(DGJNDT,"^",2),$P(DGJTNOD,"^",12)]"":$P(DGJTNOD,"^",12),1:$P(DGJTNOD,"^",9)) D SET Q
- I $D(DGJFSIG) D K DGJFSIG Q
- .I $P(DGJNDT,"^",3)']""!($P(DGJNDT,"^",4)']"") S DGJX=$S($P(DGJNDT,"^",2)]"":$P(DGJNDT,"^",2),$P(DGJTNOD,"^",12)]"":$P(DGJTNOD,"^",12),1:$P(DGJTNOD,"^",9)) D SET Q
- .S DGJX=$S($P(DGJTDV,"^",10)="P":$P(DGJTNOD,"^",9),$P(DGJTDV,"^",10)="A":$P(DGJTNOD,"^",10),1:"") Q:DGJX=DGJTPD D SET Q
- I $D(DGJFREV) D K DGJFREV Q
- .I $P(DGJNDT,"^",5)']""!($P(DGJNDT,"^",6)']"") I $P(DGJNDT,"^",2)]"" S DGJX=$S($P(DGJTDV,"^",10)="P":$P(DGJTNOD,"^",9),$P(DGJTDV,"^",10)="A":$P(DGJTNOD,"^",10),1:"") D SET Q
- .I $P(DGJNDT,"^",5)']""!($P(DGJNDT,"^",6)']"") I $P(DGJNDT,"^",2)']"" S DGJX=$S($P(DGJTNOD,"^",12)]"":$P(DGJTNOD,"^",12),$P(DGJTNOD,"^",9)]"":$P(DGJTNOD,"^",9),1:"") D SET Q
- .S DGJX=$S($P(DGJTDV,"^",3)=0:$P(DGJNDT,"^",6),$P(DGJTDV,"^",4)="P":$P(DGJTNOD,"^",9),$P(DGJTDV,"^",4)="A":$P(DGJTNOD,"^",10),1:"") D SET Q
- I $D(DGJREVD) D K DGJREVD Q
- .I $P(DGJNDT,"^",7)']""!($P(DGJNDT,"^",8)']"") S DGJX=$S($P(DGJTDV,"^",4)="P":$P(DGJTNOD,"^",9),$P(DGJTDV,"^",4)="A":$P(DGJTNOD,"^",10),1:"") D SET Q
- .S DGJX=$S($P(DGJNDT,"^",7)]""&($P(DGJNDT,"^",8)]""):$P(DGJNDT,"^",8),$P(DGJTDV,"^",4)="P":$P(DGJTNOD,"^",9),$P(DGJTDV,"^",4)="A":$P(DGJTNOD,"^",10),1:"") D SET Q
- Q
- SET S $P(^VAS(393,DA,0),"^",14)=DGJX Q
- Q K DGJTDV,DGJTDEL
- QUIT K DA,DFN,DIC,DIE,DIR,DR,DTOUT,I,IFN,PTF,VAIP,DGA1,DGJC,DGJT,DGJTADN,DGJTAIFN,DGJTADTP,DGJTAT,DGJTCNT,DGJTCT,DGJTDT,DGJTDBY,DGJTDD,DGJTEDT,DGJTOUT,DGJTOA,DGJTOUT,DGJTRC,DGJTSBY,DGJTSDT,DGJTSP,DGJTSV,DGJTST,DGJTTBY,DGJTWD1,DGJFFL,DGJTPR
- K DGT,DGJTCFLG,DGJTSDT,DGJTTBY,DGJTTD,DGJTYP,DGJTWD,DGJTX,DGPM2X,DGPMCA,DGPMDCD,DGPMT,DGPMVI,DGPMY,DIV,X,^UTILITY("DGJTADM",$J),Y,OK,POP,VAERR,DGJT1PH,DGJT2PH,DGJTCH,DGJTCH1,DGJTFG,DGJTFL,DGJTDDT,DGJTF,VAINDT
- K DIC("S"),DIC("A") Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGJTUTL 4586 printed Feb 18, 2025@23:27:19 Page 2
- DGJTUTL ;ALB/MIR - ZSECUTABLE HELP FOR EVENT DATE IN INCOMPLETE RECORD FILE ; 04 JAN 91
- +1 ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- +2 NEW DFN,I,J,OK,PTF
- SET DFN=+^VAS(393,DA,0)
- +3 DO WARN
- +4 ;
- +5 WRITE !,"Choose from:"
- +6 FOR I=0:0
- SET I=$ORDER(^UTILITY("DGJTADM",$JOB,I))
- if 'I
- QUIT
- SET Y=+^DGPM(I,0)
- XECUTE ^DD("DD")
- WRITE !?5,Y
- +7 ;
- PTF ;Check to make sure PTF exists and it is not closed
- +1 SET OK=$SELECT('$DATA(^DGPT(+PTF)):0,$DATA(^DGP(45.84,+PTF)):0,1:1)
- +2 QUIT
- PHYSRTRG SET DGJTEST=$PIECE(^VAS(393,D0,0),"^",11)
- SET X=$SELECT(DGJTEST=$ORDER(^DG(393.2,"B","TRANSCRIBED",0)):0,DGJTEST=$ORDER(^DG(393.2,"B","SIGNED",0)):0,DGJTEST=$ORDER(^DG(393.2,"B","REVIEWED",0)):0,1:1)
- KILL DGJTEST
- QUIT
- LESS48 ;Checking for discharge summary less than 48 hours.
- +1 IF $DATA(^VAS(393,DA,"DT"))
- IF $PIECE(^("DT"),"^",1)]""
- SET X=0
- QUIT
- +2 SET (DGJTX4,X1)=$PIECE(^DGPM(+$PIECE(DGJTNO,"^",4),0),"^",1)
- SET DGJTX3=+$PIECE(DGJTNO,"^",3)
- SET X2=2
- DO C^%DTC
- IF DGJTX3<X&($PIECE(DGJTNO,"^",3)>DGJTX4)
- DO ASK
- KILL DGJTX3,DGJTX4
- +3 QUIT
- ASK WRITE !!,"Will this Discharge Summary <48 hrs need to be dictated? "
- +1 SET %=2
- DO YN^DICN
- IF '%
- WRITE !,"ENTER:",!?10,"Y for YES",!?10,"N for NO",!?10,"^ to EXIT"
- GOTO ASK
- +2 SET X=$SELECT(%=2:1,%=-1:"-1",1:0)
- +3 QUIT
- TS DO FULL^VALM1
- DO EXP^DGJTEE1
- GOTO TSQ
- TSQ DO EVDT^DGJTEE
- SET VALMBG=1
- SET VALMBCK="R"
- QUIT
- WARN KILL ^UTILITY("DGJTADM",$JOB)
- +1 SET DGJTCNT=0
- FOR I=0:0
- SET I=$ORDER(^DGPM("ATID1",DFN,I))
- if 'I
- QUIT
- SET IFN=$ORDER(^(I,0))
- IF $DATA(^DGPM(IFN,0))
- IF ($PIECE(^(0),"^",2)=1)
- SET DGJTCNT=DGJTCNT+1
- SET ^UTILITY("DGJTADM",$JOB,DGJTCNT,IFN)=""
- +2 IF '$DATA(^UTILITY("DGJTADM",$JOB))
- WRITE !!,*7," Patient has no admissions on file in this facility",!
- QUIT
- +3 KILL OK,I,PTF
- +4 QUIT
- +5 ;
- +6 ;
- WR ;write node from delinquent records file
- +1 NEW X,Y
- +2 SET X=$PIECE(DGJT,"^",2)
- +3 WRITE $SELECT(X]""&($DATA(^VAS(393.3,+X,0))):$PIECE(^VAS(393.3,+X,0),"^",1),1:"UNKNOWN DEFICIENCY")
- +4 SET Y=$PIECE(DGJT,"^",3)
- IF Y]""
- XECUTE ^DD("DD")
- WRITE ?45,Y
- +5 QUIT
- +6 ;
- +7 ;
- WARD ; -- find last ward for event driver
- +1 ; input CA = ifn of cors adm
- +2 NEW IDT,MVT,M
- +3 SET X=""
- +4 FOR IDT=0:0
- SET IDT=$ORDER(^DGPM("APMV",DFN,CA,IDT))
- if 'IDT
- QUIT
- FOR MVT=0:0
- SET MVT=$ORDER(^DGPM("APMV",DFN,CA,IDT,MVT))
- if 'MVT
- QUIT
- IF $DATA(^DGPM(MVT,0))
- SET M=^(0)
- IF "^13^43^44^45^"'[(U_$PIECE(M,U,18)_U)
- IF $DATA(^DIC(42,+$PIECE(M,U,6),0))
- SET X=+$PIECE(M,U,6)
- GOTO WARDQ
- WARDQ QUIT
- PHYDEF ;Cross-reference on the Date Transcribed,10.03; Transcribed By,10.04
- +1 ; Date Signed,10.05; Signed By,10.06
- +2 ;to update the Physician for Deficiency field (#.14)
- +3 ;in the Incomplete Records Tracking file (#393)
- +4 NEW DGJX,DGJTNOD,DGJTDV,DGJTDN,DGJTPD,DGJNDT
- +5 SET DGJTNOD=$GET(^VAS(393,DA,0))
- SET DGJTDV=$PIECE(DGJTNOD,"^",6)
- +6 SET DGJTDV=$GET(^DG(40.8,DGJTDV,"DT"))
- +7 IF $DATA(DGJATTD)
- IF $PIECE(DGJTNOD,"^",11)=$ORDER(^DG(393.2,"B","TRANSCRIBED",0))&($PIECE(DGJTDV,"^",10)="A")!($PIECE(DGJTNOD,"^",11)=$ORDER(^DG(393.2,"B","SIGNED",0))&($PIECE(DGJTDV,"^",4)="A"))
- SET DGJX=$PIECE(DGJTNOD,"^",10)
- DO SET
- KILL DGJATTD
- QUIT
- +8 SET DGJTPD=$PIECE(DGJTNOD,"^",14)
- +9 SET DGJNDT=$GET(^VAS(393,DA,"DT"))
- +10 IF $DATA(DGJFDIC)
- Begin DoDot:1
- +11 SET DGJX=$SELECT($PIECE(DGJNDT,"^",2)]""&($PIECE(DGJNDT,"^",1)]""):$PIECE(DGJNDT,"^",2),$PIECE(DGJTNOD,"^",12)]"":$PIECE(DGJTNOD,"^",12),1:$PIECE(DGJTNOD,"^",9))
- DO SET
- QUIT
- End DoDot:1
- KILL DGJFDIC
- QUIT
- +12 IF $DATA(DGJFSIG)
- Begin DoDot:1
- +13 IF $PIECE(DGJNDT,"^",3)']""!($PIECE(DGJNDT,"^",4)']"")
- SET DGJX=$SELECT($PIECE(DGJNDT,"^",2)]"":$PIECE(DGJNDT,"^",2),$PIECE(DGJTNOD,"^",12)]"":$PIECE(DGJTNOD,"^",12),1:$PIECE(DGJTNOD,"^",9))
- DO SET
- QUIT
- +14 SET DGJX=$SELECT($PIECE(DGJTDV,"^",10)="P":$PIECE(DGJTNOD,"^",9),$PIECE(DGJTDV,"^",10)="A":$PIECE(DGJTNOD,"^",10),1:"")
- if DGJX=DGJTPD
- QUIT
- DO SET
- QUIT
- End DoDot:1
- KILL DGJFSIG
- QUIT
- +15 IF $DATA(DGJFREV)
- Begin DoDot:1
- +16 IF $PIECE(DGJNDT,"^",5)']""!($PIECE(DGJNDT,"^",6)']"")
- IF $PIECE(DGJNDT,"^",2)]""
- SET DGJX=$SELECT($PIECE(DGJTDV,"^",10)="P":$PIECE(DGJTNOD,"^",9),$PIECE(DGJTDV,"^",10)="A":$PIECE(DGJTNOD,"^",10),1:"")
- DO SET
- QUIT
- +17 IF $PIECE(DGJNDT,"^",5)']""!($PIECE(DGJNDT,"^",6)']"")
- IF $PIECE(DGJNDT,"^",2)']""
- SET DGJX=$SELECT($PIECE(DGJTNOD,"^",12)]"":$PIECE(DGJTNOD,"^",12),$PIECE(DGJTNOD,"^",9)]"":$PIECE(DGJTNOD,"^",9),1:"")
- DO SET
- QUIT
- +18 SET DGJX=$SELECT($PIECE(DGJTDV,"^",3)=0:$PIECE(DGJNDT,"^",6),$PIECE(DGJTDV,"^",4)="P":$PIECE(DGJTNOD,"^",9),$PIECE(DGJTDV,"^",4)="A":$PIECE(DGJTNOD,"^",10),1:"")
- DO SET
- QUIT
- End DoDot:1
- KILL DGJFREV
- QUIT
- +19 IF $DATA(DGJREVD)
- Begin DoDot:1
- +20 IF $PIECE(DGJNDT,"^",7)']""!($PIECE(DGJNDT,"^",8)']"")
- SET DGJX=$SELECT($PIECE(DGJTDV,"^",4)="P":$PIECE(DGJTNOD,"^",9),$PIECE(DGJTDV,"^",4)="A":$PIECE(DGJTNOD,"^",10),1:"")
- DO SET
- QUIT
- +21 SET DGJX=$SELECT($PIECE(DGJNDT,"^",7)]""&($PIECE(DGJNDT,"^",8)]""):$PIECE(DGJNDT,"^",8),$PIECE(DGJTDV,"^",4)="P":$PIECE(DGJTNOD,"^",9),$PIECE(DGJTDV,"^",4)="A":$PIECE(DGJTNOD,"^",10),1:"")
- DO SET
- QUIT
- End DoDot:1
- KILL DGJREVD
- QUIT
- +22 QUIT
- SET SET $PIECE(^VAS(393,DA,0),"^",14)=DGJX
- QUIT
- Q KILL DGJTDV,DGJTDEL
- QUIT KILL DA,DFN,DIC,DIE,DIR,DR,DTOUT,I,IFN,PTF,VAIP,DGA1,DGJC,DGJT,DGJTADN,DGJTAIFN,DGJTADTP,DGJTAT,DGJTCNT,DGJTCT,DGJTDT,DGJTDBY,DGJTDD,DGJTEDT,DGJTOUT,DGJTOA,DGJTOUT,DGJTRC,DGJTSBY,DGJTSDT,DGJTSP,DGJTSV,DGJTST,DGJTTBY,DGJTWD1,DGJFFL,DGJTPR
- +1 KILL DGT,DGJTCFLG,DGJTSDT,DGJTTBY,DGJTTD,DGJTYP,DGJTWD,DGJTX,DGPM2X,DGPMCA,DGPMDCD,DGPMT,DGPMVI,DGPMY,DIV,X,^UTILITY("DGJTADM",$JOB),Y,OK,POP,VAERR,DGJT1PH,DGJT2PH,DGJTCH,DGJTCH1,DGJTFG,DGJTFL,DGJTDDT,DGJTF,VAINDT
- +2 KILL DIC("S"),DIC("A")
- QUIT
