- TIUPUTPN ; SLC/JER - PN Look-up Method ;4/18/03
- ;;1.0;TEXT INTEGRATION UTILITIES;**3,21,100,131,113**;Jun 20, 1997
- LOOKUP ; Look-up code used by router/filer
- ; Required: TIUSSN, TIUVDT
- N DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
- N TIUDPRM
- I $S('$D(TIUSSN):1,'$D(TIUVDT):1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,1:0) S Y=-1 G LOOKUPX
- I TIUSSN?3N1P2N1P4N.E S TIUSSN=$TR(TIUSSN,"-/","")
- I TIUSSN["?" S Y=-1 G LOOKUPX
- S TIULOC=+$$ILOC(TIULOC)
- I '$D(^SC(+$G(TIULOC),0)) S Y=-1 G LOOKUPX
- S TIUINST=+$$DIVISION^TIULC1(TIULOC)
- S TIUEDT=$$IDATE^TIULC(TIUVDT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
- I +TIUEDT'>0 S Y=-1 Q
- S TIUTYPE=$$WHATITLE(TIUTITLE)
- I +TIUTYPE'>0 S Y=-1 Q
- ; -- Abort upload if title is consult title:
- I $$ISA^TIULX(+TIUTYPE,+$$CLASS^TIUCNSLT) S Y=-1 Q ; TIU*1*131
- D DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
- I $P($G(^SC(+TIULOC,0)),U,3)="W" D I 1
- . D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
- E D MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
- I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
- I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUVDT),".") S Y=-1 G LOOKUPX
- S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
- ;S Y=$$GETREC^TIUEDI1(DFN,.TIU,1,.TIUNEW,.TIUDPRM)
- S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
- I +Y'>0 G LOOKUPX
- ; If record is not new, has text and can be edited, then replace
- ; existing text
- I +$G(TIUNEW)'>0 D
- . S TIUEDIT=$$CANEDIT(+Y)
- . I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
- . I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
- I +Y'>0 Q
- D STUFREC(Y,+$G(TIUDAD))
- I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
- K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
- LOOKUPX Q
- ILOC(LOCATION) ; Get pointer to file 44
- N DIC,X,Y
- S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
- Q Y
- CANEDIT(DA) ; Check whether or not document is released
- Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
- MAKEADD() ; Create an addendum record
- N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
- S TIUATYP=+$$WHATITLE("ADDENDUM")
- S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
- D ^DIC
- S DA=+Y
- I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
- K TIUHDR(.01)
- Q +DA
- STUFREC(DA,PARENT) ; Stuff fixed field data
- N FDA,FDARR,IENS,FLAGS,TIUMSG
- S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
- I +$G(PARENT)'>0 D
- . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
- . S @FDARR@(.05)=3
- . S @FDARR@(.07)=$P($G(TIU("EDT")),U)
- . S @FDARR@(.08)=$P($G(TIU("LDT")),U)
- . S @FDARR@(1201)=$$NOW^TIULC
- . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
- . ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
- . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
- I +$G(PARENT)>0 D
- . S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
- . S @FDARR@(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3),@FDARR@(.05)=3
- . S @FDARR@(.06)=PARENT
- . S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
- . S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
- . S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
- . S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
- . S @FDARR@(1201)=$$NOW^TIULC
- S @FDARR@(1205)=$P($G(TIU("LOC")),U)
- S @FDARR@(1212)=$P($G(TIU("INST")),U)
- S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
- I $S(@FDARR@(1301)'>0:1,$P(@FDARR@(1301),".",2)']"":1,1:0) D
- . S @FDARR@(1301)=$S($P($G(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$G(@FDARR@(.07)))
- S @FDARR@(1303)="U"
- D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
- Q
- DELTEXT(DA) ; Delete existing text in preparation for replacement
- N DIE,DR,X,Y
- S DIE=8925,DR="2///@" D ^DIE
- Q
- WHATYPE(X) ; Identify document type
- ; Receives: X=Document Definition Name
- ; Returns: Y=Document Definition IFN
- N DIC,Y,TIUFPRIV S TIUFPRIV=1
- S DIC=8925.1,DIC(0)="M"
- S DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
- D ^DIC K DIC("S")
- WHATYPX Q Y
- WHATITLE(X) ; Identify document title
- ; Receives: X=Document Definition Name
- ; Returns: Y=Document Definition IFN
- N DIC,Y,TIUFPRIV S TIUFPRIV=1
- S DIC=8925.1,DIC(0)="M"
- S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
- D ^DIC K DIC("S")
- WHATITX Q Y
- FOLLOWUP(TIUDA) ; Post-filing code for PROGRESS NOTES
- N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
- S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
- S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
- I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
- . S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
- D FILE^DIE(FLAGS,"FDA","TIUMSG")
- I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
- . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
- D RELEASE^TIUT(TIUDA,1)
- D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
- I '$D(TIU("VSTR")) D
- . N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
- . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
- . S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
- . S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
- . S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
- . I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
- . D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
- Q:'$D(TIU("VSTR"))
- D ENQ^TIUPXAP1 ; Get/file VISIT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTPN 5264 printed Feb 19, 2025@00:11:09 Page 2
- TIUPUTPN ; SLC/JER - PN Look-up Method ;4/18/03
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**3,21,100,131,113**;Jun 20, 1997
- LOOKUP ; Look-up code used by router/filer
- +1 ; Required: TIUSSN, TIUVDT
- +2 NEW DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
- +3 NEW TIUDPRM
- +4 IF $SELECT('$DATA(TIUSSN):1,'$DATA(TIUVDT):1,$GET(TIUSSN)?4N:1,$GET(TIUSSN)']"":1,1:0)
- SET Y=-1
- GOTO LOOKUPX
- +5 IF TIUSSN?3N1P2N1P4N.E
- SET TIUSSN=$TRANSLATE(TIUSSN,"-/","")
- +6 IF TIUSSN["?"
- SET Y=-1
- GOTO LOOKUPX
- +7 SET TIULOC=+$$ILOC(TIULOC)
- +8 IF '$DATA(^SC(+$GET(TIULOC),0))
- SET Y=-1
- GOTO LOOKUPX
- +9 SET TIUINST=+$$DIVISION^TIULC1(TIULOC)
- +10 SET TIUEDT=$$IDATE^TIULC(TIUVDT)
- SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
- +11 IF +TIUEDT'>0
- SET Y=-1
- QUIT
- +12 SET TIUTYPE=$$WHATITLE(TIUTITLE)
- +13 IF +TIUTYPE'>0
- SET Y=-1
- QUIT
- +14 ; -- Abort upload if title is consult title:
- +15 ; TIU*1*131
- IF $$ISA^TIULX(+TIUTYPE,+$$CLASS^TIUCNSLT)
- SET Y=-1
- QUIT
- +16 DO DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
- +17 IF $PIECE($GET(^SC(+TIULOC,0)),U,3)="W"
- Begin DoDot:1
- +18 DO MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
- End DoDot:1
- IF 1
- +19 IF '$TEST
- DO MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
- +20 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,1:0)
- SET Y=-1
- GOTO LOOKUPX
- +21 IF $PIECE(+$GET(TIU("EDT")),".")'=$PIECE($$IDATE^TIULC(TIUVDT),".")
- SET Y=-1
- GOTO LOOKUPX
- +22 SET TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
- +23 ;S Y=$$GETREC^TIUEDI1(DFN,.TIU,1,.TIUNEW,.TIUDPRM)
- +24 SET Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
- +25 IF +Y'>0
- GOTO LOOKUPX
- +26 ; If record is not new, has text and can be edited, then replace
- +27 ; existing text
- +28 IF +$GET(TIUNEW)'>0
- Begin DoDot:1
- +29 SET TIUEDIT=$$CANEDIT(+Y)
- +30 IF +TIUEDIT>0
- IF $DATA(^TIU(8925,+Y,"TEXT"))
- DO DELTEXT(+Y)
- +31 IF +TIUEDIT'>0
- SET TIUDAD=+Y
- SET Y=$$MAKEADD
- End DoDot:1
- +32 IF +Y'>0
- QUIT
- +33 DO STUFREC(Y,+$GET(TIUDAD))
- +34 IF +$GET(TIUDAD)
- DO SENDADD^TIUALRT(+Y)
- +35 KILL TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
- LOOKUPX QUIT
- ILOC(LOCATION) ; Get pointer to file 44
- +1 NEW DIC,X,Y
- +2 SET DIC=44
- SET DIC(0)="M"
- SET X=LOCATION
- DO ^DIC
- +3 QUIT Y
- CANEDIT(DA) ; Check whether or not document is released
- +1 QUIT $SELECT(+$PIECE($GET(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
- MAKEADD() ; Create an addendum record
- +1 NEW DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV
- SET TIUFPRIV=1
- +2 SET TIUATYP=+$$WHATITLE("ADDENDUM")
- +3 SET (DIC,DLAYGO)=8925
- SET DIC(0)="L"
- SET X=""""_"`"_TIUATYP_""""
- +4 DO ^DIC
- +5 SET DA=+Y
- +6 IF +DA>0
- SET DIE=DIC
- SET DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP)
- DO ^DIE
- +7 KILL TIUHDR(.01)
- +8 QUIT +DA
- STUFREC(DA,PARENT) ; Stuff fixed field data
- +1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG
- +2 SET IENS=""""_DA_","""
- SET FDARR="FDA(8925,"_IENS_")"
- SET FLAGS="K"
- +3 IF +$GET(PARENT)'>0
- Begin DoDot:1
- +4 SET @FDARR@(.02)=$GET(DFN)
- SET @FDARR@(.03)=$PIECE($GET(TIU("VISIT")),U)
- +5 SET @FDARR@(.05)=3
- +6 SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
- +7 SET @FDARR@(.08)=$PIECE($GET(TIU("LDT")),U)
- +8 SET @FDARR@(1201)=$$NOW^TIULC
- +9 SET @FDARR@(1205)=$SELECT(+$PIECE($GET(TIU("LOC")),U):$PIECE($GET(TIU("LOC")),U),1:$PIECE($GET(TIU("VLOC")),U))
- +10 ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
- +11 SET @FDARR@(1404)=$PIECE($GET(TIU("SVC")),U)
- End DoDot:1
- +12 IF +$GET(PARENT)>0
- Begin DoDot:1
- +13 SET @FDARR@(.02)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,2)
- +14 SET @FDARR@(.03)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,3)
- SET @FDARR@(.05)=3
- +15 SET @FDARR@(.06)=PARENT
- +16 SET @FDARR@(.07)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,7)
- +17 SET @FDARR@(.08)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,8)
- +18 SET @FDARR@(1205)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,5)
- +19 SET @FDARR@(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
- +20 SET @FDARR@(1201)=$$NOW^TIULC
- End DoDot:1
- +21 SET @FDARR@(1205)=$PIECE($GET(TIU("LOC")),U)
- +22 SET @FDARR@(1212)=$PIECE($GET(TIU("INST")),U)
- +23 SET @FDARR@(1301)=$SELECT($GET(TIUDDT)]"":$$IDATE^TIULC($GET(TIUDDT)),1:"")
- +24 IF $SELECT(@FDARR@(1301)'>0:1,$PIECE(@FDARR@(1301),".",2)']"":1,1:0)
- Begin DoDot:1
- +25 SET @FDARR@(1301)=$SELECT($PIECE($GET(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$GET(@FDARR@(.07)))
- End DoDot:1
- +26 SET @FDARR@(1303)="U"
- +27 ; File record
- DO FILE^DIE(FLAGS,"FDA","TIUMSG")
- +28 QUIT
- DELTEXT(DA) ; Delete existing text in preparation for replacement
- +1 NEW DIE,DR,X,Y
- +2 SET DIE=8925
- SET DR="2///@"
- DO ^DIE
- +3 QUIT
- WHATYPE(X) ; Identify document type
- +1 ; Receives: X=Document Definition Name
- +2 ; Returns: Y=Document Definition IFN
- +3 NEW DIC,Y,TIUFPRIV
- SET TIUFPRIV=1
- +4 SET DIC=8925.1
- SET DIC(0)="M"
- +5 SET DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
- +6 DO ^DIC
- KILL DIC("S")
- WHATYPX QUIT Y
- WHATITLE(X) ; Identify document title
- +1 ; Receives: X=Document Definition Name
- +2 ; Returns: Y=Document Definition IFN
- +3 NEW DIC,Y,TIUFPRIV
- SET TIUFPRIV=1
- +4 SET DIC=8925.1
- SET DIC(0)="M"
- +5 SET DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
- +6 DO ^DIC
- KILL DIC("S")
- WHATITX QUIT Y
- FOLLOWUP(TIUDA) ; Post-filing code for PROGRESS NOTES
- +1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
- +2 SET IENS=""""_TIUDA_","""
- SET FDARR="FDA(8925,"_IENS_")"
- SET FLAGS="K"
- +3 SET @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
- +4 IF +$PIECE($GET(^TIU(8925,TIUDA,12)),U,9)
- IF '+$PIECE($GET(^(12)),U,8)
- Begin DoDot:1
- +5 SET @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
- End DoDot:1
- +6 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
- +7 IF +$PIECE($GET(^TIU(8925,+TIUDA,12)),U,8)
- IF (+$PIECE($GET(^TIU(8925,+TIUDA,12)),U,4)'=+$PIECE($GET(^(12)),U,8))
- Begin DoDot:1
- +8 SET @FDARR@(1506)=1
- DO FILE^DIE(FLAGS,"FDA","TIUMSG")
- End DoDot:1
- +9 DO RELEASE^TIUT(TIUDA,1)
- +10 DO AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
- +11 IF '$DATA(TIU("VSTR"))
- Begin DoDot:1
- +12 NEW TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
- +13 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
- SET TIUD12=$GET(^(12))
- +14 SET DFN=+$PIECE(TIUD0,U,2)
- SET TIUEDT=+$PIECE(TIUD0,U,7)
- +15 SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
- SET TIUHLOC=+$PIECE(TIUD12,U,5)
- +16 SET TIUVLOC=$SELECT(+$PIECE(TIUD12,U,11):+$PIECE(TIUD12,U,11),1:+TIUHLOC)
- +17 IF $SELECT(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0)
- QUIT
- +18 DO MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
- End DoDot:1
- +19 if '$DATA(TIU("VSTR"))
- QUIT
- +20 ; Get/file VISIT
- DO ENQ^TIUPXAP1
- +21 QUIT