TIULD ; SLC/JER - Admission related functions ; 1/13/03
;;1.0;TEXT INTEGRATION UTILITIES;**7,21,148,156**;Jun 20, 1997
;IHS/ITSC/LJF 02/26/2003 set IHS visit variable
; called IHS routines for displays
;
GETTIU(TIUY,TIUDA) ; Gets admission array for existing DCS
N TIUMVN,TIUPTF,TIUVSTR,TIUDTYP,TIUD0,TIUD12,TIUD14
S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14))
S TIUDTYP=+TIUD0,DFN=+$P(TIUD0,U,2),TIUMVN=$P(TIUD14,U)
S TIUVSTR=$P(TIUD12,U,11)_";"_$P(TIUD0,U,7)_";"_$P(TIUD0,U,13)
S TIUY("DOCTYP")=TIUDTYP_U_$$PNAME^TIULC1(TIUDTYP)
I +$G(^TIU(8925,+TIUDA,13)) S TIUY("REFDT")=+$G(^(13))
;
;IHS/ITSC/LJF 02/26/2003 set IHS visit variable from visit attached to patient movement entry
NEW BTIUVSIT
I TIUMVN S BTIUVSIT=$$GET1^DIQ(405,TIUMVN,.27,"I")
I 'TIUMVN,$P(TIUD0,U,3) S BTIUVSIT=$P(TIUD0,U,3)
I $G(BTIUVSIT) S $P(TIUVSTR,";",3)=$$GET1^DIQ(9000010,+BTIUVSIT,.07,"I")
;IHS/ITSC/LJF 02/26/2003 end of new code
;
; If the Patient Movement Pointer's broken, try to fix
I +TIUMVN,'$D(^DGPM(+TIUMVN,0)),+$G(TIUVSTR) D FIXMOVE(.TIUY,DFN,TIUVSTR,TIUDA) Q:+$G(TIUY("AD#"))
D PATVADPT^TIULV(.TIUY,DFN,TIUMVN,TIUVSTR)
Q
FIXMOVE(TIUY,DFN,TIUVSTR,TIUDA) ; See if Admission has been reinstated, and fix
N TIUEDT,TIULDT,TIULOC
S TIUEDT=$P(TIUVSTR,";",2) Q:+TIUEDT'>0
S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIULOC=+TIUVSTR
Q:+TIULDT'>0!(+TIULOC'>0)
D MAIN^TIUMOVE(.TIUY,DFN,"",TIUEDT,TIULDT,1,"LAST",0,+TIULOC)
I +$G(TIU("AD#"))>0,$D(^DGPM(+$G(TIU("AD#")))) D
. N DIE,DR,DA S DA=TIUDA,DR="1401////"_+$G(TIU("AD#")),DIE="^TIU(8925,"
. D ^DIE
Q
CHEKDS(X) ; Display/validate correct patient/treatment episode
Q $$CHEKDS^BTIULD(.X) ;IHS/ITSC/LJF 02/26/2003 use IHS code for display
N DIR,Y,TIURC S Y=0
I X("AD#")'>0!(X("EDT")="") D G CHEKDSX
. W !!,"Movement data doesn't exist for admission, can't create "
. W "Summary",!
I +$$ISA^USRLM(DUZ,"TRANSCRIPTIONIST")>0 S Y=1 G CHEKDSX
W !!?1,"Patient: ",$$NAME^TIULS(X("PNM"),"LAST, FIRST MI"),?40,"SSN: "
W X("SSN"),?62,"Sex: ",$S(X("SEX")]"":$P(X("SEX"),U,2),1:"UNKNOWN"),!
W ?5,"Age: ",$S(X("AGE")]"":X("AGE"),1:"UNKNOWN"),?40,"Claim #: "
W $S(X("CLAIM")]"":X("CLAIM"),1:"UNKNOWN"),!
W "Adm Date: ",$$DATE^TIULS($P(X("EDT"),U),"MM/DD/YY"),?40,"Ward: "
W $P(X("WARD"),U,2),!
W:X("LDT")]"" "Dis Date: ",$$DATE^TIULS(X("LDT"),"MM/DD/YY"),!
W ?2,"Adm Dx: ",X("ADDX")
; Below TIU*148
I $G(X("NUMRACE"))>0 D
. W !?4,"Race: " F TIURC=1:1:X("NUMRACE") W ?10,$P(X("RACE",TIURC),U,2),!
I $G(X("RACENO"))=0 W !?4,"Race: ",$P($G(X("RACE")),U,2),!
I $D(X("DICTDT")) D
. W !,"A DISCHARGE SUMMARY is already on file:",!
. W ?2,"Dict'd: ",X("DICTDT"),?41,"By: ",X("AUTHOR"),!
. W ?2,"Signed: ",X("SIGDT"),?35,"Cosigned: ",X("COSDT"),!
. S Y=1
E S Y=$$READ^TIUU("YO","Correct VISIT","YES")
W !
CHEKDSX Q Y
CHEKPN(X,TIUBY) ; Display/validate demographic/visit information
Q $$CHEKPN^BTIULD(.X,.TIUBY) ;IHS/ITSC/LJF 02/26/2003 use IHS code for display
W !!,"Enter/Edit "
W $S(+$G(TIUCLASS):$S(TIUCLASS=3:"PROGRESS NOTE",TIUCLASS=+$$CLASS^TIUCNSLT:"CONSULT RESULT",1:$$PNAME^TIULC1(+TIUCLASS)),1:"PROGRESS NOTE"),"..."
W !?10,"Patient Location: ",$S(+X("LOC"):$P(X("LOC"),U,2),1:"UNKNOWN")
W !?$S(+$G(X("AD#")):4,1:8),"Date/time of "
W $S(+$G(X("AD#")):"Admission: ",1:"Visit: ")
W $S(+$P($G(X("VSTR")),";",2):$$DATE^TIULS($P(X("VSTR"),";",2),"MM/DD/YY HR:MIN"),1:"UNKNOWN")
W !?9,"Date/time of Note: "
W $S(+$G(X("REFDT"))>0:$$DATE^TIULS(X("REFDT"),"MM/DD/YY HR:MIN"),1:"NOW")
S:+$G(X("REFDT"))'>0 X("REFDT")=$$NOW^TIULC
W !?12,"Author of Note: "
W $$PERSNAME^TIULC1($S($D(TIUAUTH):+TIUAUTH,1:DUZ))
S Y=$$READ^TIUU("YO"," ...OK","YES")
I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) Q 0
S TIUBY=+Y
S:'+Y Y=$$READ^TIUU("YO","Correct VISIT","YES")
I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) Q 0
I +Y'>0 D
. K X N TIUINOUT
. S TIUINOUT=$$INOUT^TIUVSIT
. I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) Q
. I $P(TIUINOUT,U)="o" D MAIN^TIUVSIT(.X,DFN,"","","","",1)
. I $P(TIUINOUT,U)'="o" D MAIN^TIUMOVE(.X,DFN,"","","",1,"LAST",1)
. S Y=$S($D(X)>9:$$CHEKPN(.X,.TIUBY),1:0)
Q Y
TIULD ; SLC/JER - Admission related functions ; 1/13/03
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**7,21,148,156**;Jun 20, 1997
+2 ;IHS/ITSC/LJF 02/26/2003 set IHS visit variable
+3 ; called IHS routines for displays
+4 ;
GETTIU(TIUY,TIUDA) ; Gets admission array for existing DCS
+1 NEW TIUMVN,TIUPTF,TIUVSTR,TIUDTYP,TIUD0,TIUD12,TIUD14
+2 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUD12=$GET(^(12))
SET TIUD14=$GET(^(14))
+3 SET TIUDTYP=+TIUD0
SET DFN=+$PIECE(TIUD0,U,2)
SET TIUMVN=$PIECE(TIUD14,U)
+4 SET TIUVSTR=$PIECE(TIUD12,U,11)_";"_$PIECE(TIUD0,U,7)_";"_$PIECE(TIUD0,U,13)
+5 SET TIUY("DOCTYP")=TIUDTYP_U_$$PNAME^TIULC1(TIUDTYP)
+6 IF +$GET(^TIU(8925,+TIUDA,13))
SET TIUY("REFDT")=+$GET(^(13))
+7 ;
+8 ;IHS/ITSC/LJF 02/26/2003 set IHS visit variable from visit attached to patient movement entry
+9 NEW BTIUVSIT
+10 IF TIUMVN
SET BTIUVSIT=$$GET1^DIQ(405,TIUMVN,.27,"I")
+11 IF 'TIUMVN
IF $PIECE(TIUD0,U,3)
SET BTIUVSIT=$PIECE(TIUD0,U,3)
+12 IF $GET(BTIUVSIT)
SET $PIECE(TIUVSTR,";",3)=$$GET1^DIQ(9000010,+BTIUVSIT,.07,"I")
+13 ;IHS/ITSC/LJF 02/26/2003 end of new code
+14 ;
+15 ; If the Patient Movement Pointer's broken, try to fix
+16 IF +TIUMVN
IF '$DATA(^DGPM(+TIUMVN,0))
IF +$GET(TIUVSTR)
DO FIXMOVE(.TIUY,DFN,TIUVSTR,TIUDA)
IF +$GET(TIUY("AD#"))
QUIT
+17 DO PATVADPT^TIULV(.TIUY,DFN,TIUMVN,TIUVSTR)
+18 QUIT
FIXMOVE(TIUY,DFN,TIUVSTR,TIUDA) ; See if Admission has been reinstated, and fix
+1 NEW TIUEDT,TIULDT,TIULOC
+2 SET TIUEDT=$PIECE(TIUVSTR,";",2)
IF +TIUEDT'>0
QUIT
+3 SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
SET TIULOC=+TIUVSTR
+4 IF +TIULDT'>0!(+TIULOC'>0)
QUIT
+5 DO MAIN^TIUMOVE(.TIUY,DFN,"",TIUEDT,TIULDT,1,"LAST",0,+TIULOC)
+6 IF +$GET(TIU("AD#"))>0
IF $DATA(^DGPM(+$GET(TIU("AD#"))))
Begin DoDot:1
+7 NEW DIE,DR,DA
SET DA=TIUDA
SET DR="1401////"_+$GET(TIU("AD#"))
SET DIE="^TIU(8925,"
+8 DO ^DIE
End DoDot:1
+9 QUIT
CHEKDS(X) ; Display/validate correct patient/treatment episode
+1 ;IHS/ITSC/LJF 02/26/2003 use IHS code for display
QUIT $$CHEKDS^BTIULD(.X)
+2 NEW DIR,Y,TIURC
SET Y=0
+3 IF X("AD#")'>0!(X("EDT")="")
Begin DoDot:1
+4 WRITE !!,"Movement data doesn't exist for admission, can't create "
+5 WRITE "Summary",!
End DoDot:1
GOTO CHEKDSX
+6 IF +$$ISA^USRLM(DUZ,"TRANSCRIPTIONIST")>0
SET Y=1
GOTO CHEKDSX
+7 WRITE !!?1,"Patient: ",$$NAME^TIULS(X("PNM"),"LAST, FIRST MI"),?40,"SSN: "
+8 WRITE X("SSN"),?62,"Sex: ",$SELECT(X("SEX")]"":$PIECE(X("SEX"),U,2),1:"UNKNOWN"),!
+9 WRITE ?5,"Age: ",$SELECT(X("AGE")]"":X("AGE"),1:"UNKNOWN"),?40,"Claim #: "
+10 WRITE $SELECT(X("CLAIM")]"":X("CLAIM"),1:"UNKNOWN"),!
+11 WRITE "Adm Date: ",$$DATE^TIULS($PIECE(X("EDT"),U),"MM/DD/YY"),?40,"Ward: "
+12 WRITE $PIECE(X("WARD"),U,2),!
+13 IF X("LDT")]""
WRITE "Dis Date: ",$$DATE^TIULS(X("LDT"),"MM/DD/YY"),!
+14 WRITE ?2,"Adm Dx: ",X("ADDX")
+15 ; Below TIU*148
+16 IF $GET(X("NUMRACE"))>0
Begin DoDot:1
+17 WRITE !?4,"Race: "
FOR TIURC=1:1:X("NUMRACE")
WRITE ?10,$PIECE(X("RACE",TIURC),U,2),!
End DoDot:1
+18 IF $GET(X("RACENO"))=0
WRITE !?4,"Race: ",$PIECE($GET(X("RACE")),U,2),!
+19 IF $DATA(X("DICTDT"))
Begin DoDot:1
+20 WRITE !,"A DISCHARGE SUMMARY is already on file:",!
+21 WRITE ?2,"Dict'd: ",X("DICTDT"),?41,"By: ",X("AUTHOR"),!
+22 WRITE ?2,"Signed: ",X("SIGDT"),?35,"Cosigned: ",X("COSDT"),!
+23 SET Y=1
End DoDot:1
+24 IF '$TEST
SET Y=$$READ^TIUU("YO","Correct VISIT","YES")
+25 WRITE !
CHEKDSX QUIT Y
CHEKPN(X,TIUBY) ; Display/validate demographic/visit information
+1 ;IHS/ITSC/LJF 02/26/2003 use IHS code for display
QUIT $$CHEKPN^BTIULD(.X,.TIUBY)
+2 WRITE !!,"Enter/Edit "
+3 WRITE $SELECT(+$GET(TIUCLASS):$SELECT(TIUCLASS=3:"PROGRESS NOTE",TIUCLASS=+$$CLASS^TIUCNSLT:"CONSULT RESULT",1:$$PNAME^TIULC1(+TIUCLASS)),1:"PROGRESS NOTE"),"..."
+4 WRITE !?10,"Patient Location: ",$SELECT(+X("LOC"):$PIECE(X("LOC"),U,2),1:"UNKNOWN")
+5 WRITE !?$SELECT(+$GET(X("AD#")):4,1:8),"Date/time of "
+6 WRITE $SELECT(+$GET(X("AD#")):"Admission: ",1:"Visit: ")
+7 WRITE $SELECT(+$PIECE($GET(X("VSTR")),";",2):$$DATE^TIULS($PIECE(X("VSTR"),";",2),"MM/DD/YY HR:MIN"),1:"UNKNOWN")
+8 WRITE !?9,"Date/time of Note: "
+9 WRITE $SELECT(+$GET(X("REFDT"))>0:$$DATE^TIULS(X("REFDT"),"MM/DD/YY HR:MIN"),1:"NOW")
+10 IF +$GET(X("REFDT"))'>0
SET X("REFDT")=$$NOW^TIULC
+11 WRITE !?12,"Author of Note: "
+12 WRITE $$PERSNAME^TIULC1($SELECT($DATA(TIUAUTH):+TIUAUTH,1:DUZ))
+13 SET Y=$$READ^TIUU("YO"," ...OK","YES")
+14 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
QUIT 0
+15 SET TIUBY=+Y
+16 IF '+Y
SET Y=$$READ^TIUU("YO","Correct VISIT","YES")
+17 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
QUIT 0
+18 IF +Y'>0
Begin DoDot:1
+19 KILL X
NEW TIUINOUT
+20 SET TIUINOUT=$$INOUT^TIUVSIT
+21 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
QUIT
+22 IF $PIECE(TIUINOUT,U)="o"
DO MAIN^TIUVSIT(.X,DFN,"","","","",1)
+23 IF $PIECE(TIUINOUT,U)'="o"
DO MAIN^TIUMOVE(.X,DFN,"","","",1,"LAST",1)
+24 SET Y=$SELECT($DATA(X)>9:$$CHEKPN(.X,.TIUBY),1:0)
End DoDot:1
+25 QUIT Y
