TIULD.m

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