TIUPUTA ; SLC/JER - Utilities for C & P Look-up, etc. ;26-MAY-1999 16:38:37
;;1.0;TEXT INTEGRATION UTILITIES;**68,237**;Jun 20, 1997;Build 2
LOOKUP ; Look-up code used by router/filer
; Required: TIUCPFN, TIUSSN
N CPDFN,DFN,TIU2507R,TIU25070
I $S('$D(TIUSSN):1,$G(TIUCPFN)']"":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
K TIUHDR(.02)
;Confirm that exam is for correct patient
S DFN=+$$PATIENT^TIULA(TIUSSN)
S TIU25070=$G(^DVB(396.4,TIUCPFN,0)),TIU2507R=+$P(TIU25070,U,2)
I TIU2507R'>0 S Y=-1 G LOOKUPX
;VMP/ELR ADD NEXT LINE. UNLESS STATUS OF EXAM IS OPEN WILL BE A FILING ERROR.
I $P(TIU25070,U,4)'="O" S Y=-1 G LOOKUPX
S CPDFN=+$G(^DVB(396.3,TIU2507R,0))
I CPDFN'=DFN S Y=-1 G LOOKUPX
S Y=$$CALLDIC(TIUCPFN)
LOOKUPX Q
CALLDIC(TIUX) ; Call ^DIC
N DA,DIC,X,Y
S DIC=396.4,DIC(0)="NX",X="`"_TIUX D ^DIC
Q Y
FOLLOWUP(TIUDA) ; Post-filing code for C&P's
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU
S IENS=""""_TIUDA_",""",FDARR="FDA(396.4,"_IENS_")",FLAGS="K"
S @FDARR@(.04)="C"
D FILE^DIE(FLAGS,"FDA","TIUMSG")
Q
FIX ; Filing error resolution code for C&P's
;VMP/ELR ADD NEXT LINE AND BYPASS THIS FIX CODE THAT DOES NOT WORK
;USER WILL NEED TO CORRECT UPLOAD IN THE BUFFER. THE EXISTING CODE DOES NOT CHECK TO SEE IF CORRECT PATIENT.
W !!,"YOU MUST EDIT THE UPLOAD BUFFER TO FIX THE FILING ERROR"
Q
N %,TIUOUT,AMIEDA,TIUX,TIUPRM0,TIUPRM1,SUCCESS,TIUBUF
; -- first, determine the correct 2507 exam record --
F D Q:$D(DUOUT)!$D(DIROUT)!+$G(TIUOUT)
. N D0,DK,DL,DIC,X,Y,DA,DX,A,S
. W ! S DIC=396.4,DIC(0)="AEMQ"
. S DIC("W")="D DICW^TIUPUTA(+Y)"
. S DIC("A")="Select 2507 EXAM REFERENCE NUMBER: "
. D ^DIC I +Y'>0 S TIUOUT=1 Q
. W ! S (DA,AMIEDA)=+Y D EN^DIQ
. S TIUOUT=$$READ^TIUU("Y","... OK","YES")
Q:$D(DUOUT)!$D(DIROUT)!+$G(DTOUT)!'+$G(AMIEDA)
; -- next, load fields from upload buffer entry --
S TIUBUF=$S(+$G(XQADATA):+$G(XQADATA),+$G(BUFDA):+$G(BUFDA),1:"")
D LOADTIUX(.TIUX,TIUBUF)
; -- finally, file data in 2507 exam file --
D ADDTEXT(AMIEDA,.TIUX)
K TIUX("TEXT")
D FILE(.SUCCESS,AMIEDA,.TIUX,TIUTYPE)
S TIUPOST=$$POSTFILE^TIULC1(TIUTYPE)
S TIUREC("#")=AMIEDA
I TIUPOST]"" X TIUPOST
FIXX D ALERTDEL^TIUPEVNT(+TIUBUF)
D RESOLVE^TIUPEVNT($S($D(XQADATA):+$P(XQADATA,";",3),1:$G(ERRDA)),1)
D BUFPURGE^TIUPUTC(+TIUBUF)
W "Done."
I +SUCCESS S TIUDONE=1
Q
DICW(TIUDA) ; Write identifiers
N X,Y,VADM,VA,VAERR,DVBCP0,DVBCPR0
S DVBCP0=^DVB(396.4,+TIUDA,0),DVBCPR0=$G(^DVB(396.3,+$P(DVBCP0,U,2),0))
W ?10,$$NAME^TIULS($$NAME^TIULO(+DVBCPR0),"LAST,FIRST MI")," ",?37,$$SSN^TIULO(+DVBCPR0)," ",?52,$P(^DVB(396.6,+$P(DVBCP0,U,3),0),U,2)
Q
LOADTIUX(TIUARR,TIUBUF) ; Load TIUX array with header and text
N TIUI,TIUHSIG,TIUBGN,TIULINE,X,Y,TYPE I '$D(TIUPRM0) D SETPARM^TIULE
S TIUHSIG=$P(TIUPRM0,U,10),TIUBGN=$P(TIUPRM0,U,12)
S TIUI=0 F S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0 D
. S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
. I TIULINE[TIUHSIG D
. . N TIUD1,TIUD4
. . S X=$$STRIP^TIULS($P(TIULINE,":",2)),Y=$$WHATYPE^TIUPUTU(X)
. . I +Y'>0 D MAIN^TIUPEVNT(TIUBUF,1,3,X) Q
. . S TIUD1=$G(^TIU(8925.1,+Y,1)),TIUD4=$G(^TIU(8925.1,+Y,4))
. . S TYPE=+Y
. . F D Q:TIULINE[TIUBGN!(+TIUI'>0)
. . . N TIUN,TIUCAP,TIUFLD,TIUREQ S TIUREQ=0
. . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
. . . S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0)) Q:TIULINE[TIUBGN
. . . S TIUCAP=$P(TIULINE,":") Q:TIUCAP']""
. . . S TIUN=$O(^TIU(8925.1,+TYPE,"HEAD","B",TIUCAP,0))
. . . Q:+TIUN'>0
. . . S TIUFLD=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,3)
. . . Q:TIUFLD']""
. . . S TIUREQ=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,7)
. . . S TIUARR(TIUFLD)=$$STRIP^TIULS($P(TIULINE,":",2,99))
. . . S:TIUFLD'=.001 TIUARR(TIUFLD)=$$TRNSFRM^TIUPEFIX(+TYPE,TIUFLD,TIUARR(TIUFLD))
. . . I +TIUREQ,TIUARR(TIUFLD)="" S TIUARR(TIUFLD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
. . . I $S(TIUFLD=.001:1,TIUFLD=.02:1,1:0) K TIUARR(TIUFLD)
. . I TIULINE[TIUBGN D
. . . N TIUJ S TIUJ=0
. . . F D Q:+TIUI'>0
. . . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
. . . . S TIUJ=TIUJ+1
. . . . S TIUARR("TEXT",TIUJ,0)=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
. . . . S TIUARR("TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
Q
ADDTEXT(AMIEDA,TIUX) ; File Text
N TIUI,TIUJ S TIUI=0,TIUJ=+$P($G(^DVB(396.4,+AMIEDA,"RES",0)),U,3)
F S TIUI=$O(TIUX("TEXT",TIUI)) Q:+TIUI'>0 D
. S TIUJ=TIUJ+1,^DVB(396.4,+AMIEDA,"RES",TIUJ,0)=$G(TIUX("TEXT",TIUI,0))
. S ^DVB(396.4,+AMIEDA,"RES",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
Q
FILE(SUCCESS,AMIEDA,TIUX,RTYPE) ; Call FM Filer to commit updates to DB
N FDA,FDARR,IENS,FLAGS,TIUMSG
S IENS=""""_AMIEDA_",""",FDARR="FDA(396.4,"_IENS_")",FLAGS="KE"
M @FDARR=TIUX
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
I $D(TIUMSG)>9 D
. S SUCCESS=0_U_$G(TIUMSG(1,"TEXT",1))
. D MAIN^TIUPEVNT(TIUBUF,2,"",$P($G(^TIU(8925.1,+RTYPE,0)),U),.FDA,.TIUMSG)
S SUCCESS=AMIEDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTA 5068 printed Apr 09, 2024@21:45:12 Page 2
TIUPUTA ; SLC/JER - Utilities for C & P Look-up, etc. ;26-MAY-1999 16:38:37
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**68,237**;Jun 20, 1997;Build 2
LOOKUP ; Look-up code used by router/filer
+1 ; Required: TIUCPFN, TIUSSN
+2 NEW CPDFN,DFN,TIU2507R,TIU25070
+3 IF $SELECT('$DATA(TIUSSN):1,$GET(TIUCPFN)']"":1,$GET(TIUSSN)?4N:1,$GET(TIUSSN)']"":1,1:0)
SET Y=-1
GOTO LOOKUPX
+4 IF TIUSSN?3N1P2N1P4N.E
SET TIUSSN=$TRANSLATE(TIUSSN,"-/","")
+5 IF TIUSSN["?"
SET Y=-1
GOTO LOOKUPX
+6 KILL TIUHDR(.02)
+7 ;Confirm that exam is for correct patient
+8 SET DFN=+$$PATIENT^TIULA(TIUSSN)
+9 SET TIU25070=$GET(^DVB(396.4,TIUCPFN,0))
SET TIU2507R=+$PIECE(TIU25070,U,2)
+10 IF TIU2507R'>0
SET Y=-1
GOTO LOOKUPX
+11 ;VMP/ELR ADD NEXT LINE. UNLESS STATUS OF EXAM IS OPEN WILL BE A FILING ERROR.
+12 IF $PIECE(TIU25070,U,4)'="O"
SET Y=-1
GOTO LOOKUPX
+13 SET CPDFN=+$GET(^DVB(396.3,TIU2507R,0))
+14 IF CPDFN'=DFN
SET Y=-1
GOTO LOOKUPX
+15 SET Y=$$CALLDIC(TIUCPFN)
LOOKUPX QUIT
CALLDIC(TIUX) ; Call ^DIC
+1 NEW DA,DIC,X,Y
+2 SET DIC=396.4
SET DIC(0)="NX"
SET X="`"_TIUX
DO ^DIC
+3 QUIT Y
FOLLOWUP(TIUDA) ; Post-filing code for C&P's
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIU
+2 SET IENS=""""_TIUDA_","""
SET FDARR="FDA(396.4,"_IENS_")"
SET FLAGS="K"
+3 SET @FDARR@(.04)="C"
+4 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+5 QUIT
FIX ; Filing error resolution code for C&P's
+1 ;VMP/ELR ADD NEXT LINE AND BYPASS THIS FIX CODE THAT DOES NOT WORK
+2 ;USER WILL NEED TO CORRECT UPLOAD IN THE BUFFER. THE EXISTING CODE DOES NOT CHECK TO SEE IF CORRECT PATIENT.
+3 WRITE !!,"YOU MUST EDIT THE UPLOAD BUFFER TO FIX THE FILING ERROR"
+4 QUIT
+5 NEW %,TIUOUT,AMIEDA,TIUX,TIUPRM0,TIUPRM1,SUCCESS,TIUBUF
+6 ; -- first, determine the correct 2507 exam record --
+7 FOR
Begin DoDot:1
+8 NEW D0,DK,DL,DIC,X,Y,DA,DX,A,S
+9 WRITE !
SET DIC=396.4
SET DIC(0)="AEMQ"
+10 SET DIC("W")="D DICW^TIUPUTA(+Y)"
+11 SET DIC("A")="Select 2507 EXAM REFERENCE NUMBER: "
+12 DO ^DIC
IF +Y'>0
SET TIUOUT=1
QUIT
+13 WRITE !
SET (DA,AMIEDA)=+Y
DO EN^DIQ
+14 SET TIUOUT=$$READ^TIUU("Y","... OK","YES")
End DoDot:1
if $DATA(DUOUT)!$DATA(DIROUT)!+$GET(TIUOUT)
QUIT
+15 if $DATA(DUOUT)!$DATA(DIROUT)!+$GET(DTOUT)!'+$GET(AMIEDA)
QUIT
+16 ; -- next, load fields from upload buffer entry --
+17 SET TIUBUF=$SELECT(+$GET(XQADATA):+$GET(XQADATA),+$GET(BUFDA):+$GET(BUFDA),1:"")
+18 DO LOADTIUX(.TIUX,TIUBUF)
+19 ; -- finally, file data in 2507 exam file --
+20 DO ADDTEXT(AMIEDA,.TIUX)
+21 KILL TIUX("TEXT")
+22 DO FILE(.SUCCESS,AMIEDA,.TIUX,TIUTYPE)
+23 SET TIUPOST=$$POSTFILE^TIULC1(TIUTYPE)
+24 SET TIUREC("#")=AMIEDA
+25 IF TIUPOST]""
XECUTE TIUPOST
FIXX DO ALERTDEL^TIUPEVNT(+TIUBUF)
+1 DO RESOLVE^TIUPEVNT($SELECT($DATA(XQADATA):+$PIECE(XQADATA,";",3),1:$GET(ERRDA)),1)
+2 DO BUFPURGE^TIUPUTC(+TIUBUF)
+3 WRITE "Done."
+4 IF +SUCCESS
SET TIUDONE=1
+5 QUIT
DICW(TIUDA) ; Write identifiers
+1 NEW X,Y,VADM,VA,VAERR,DVBCP0,DVBCPR0
+2 SET DVBCP0=^DVB(396.4,+TIUDA,0)
SET DVBCPR0=$GET(^DVB(396.3,+$PIECE(DVBCP0,U,2),0))
+3 WRITE ?10,$$NAME^TIULS($$NAME^TIULO(+DVBCPR0),"LAST,FIRST MI")," ",?37,$$SSN^TIULO(+DVBCPR0)," ",?52,$PIECE(^DVB(396.6,+$PIECE(DVBCP0,U,3),0),U,2)
+4 QUIT
LOADTIUX(TIUARR,TIUBUF) ; Load TIUX array with header and text
+1 NEW TIUI,TIUHSIG,TIUBGN,TIULINE,X,Y,TYPE
IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+2 SET TIUHSIG=$PIECE(TIUPRM0,U,10)
SET TIUBGN=$PIECE(TIUPRM0,U,12)
+3 SET TIUI=0
FOR
SET TIUI=$ORDER(^TIU(8925.2,+TIUBUF,"TEXT",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+4 SET TIULINE=$GET(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
+5 IF TIULINE[TIUHSIG
Begin DoDot:2
+6 NEW TIUD1,TIUD4
+7 SET X=$$STRIP^TIULS($PIECE(TIULINE,":",2))
SET Y=$$WHATYPE^TIUPUTU(X)
+8 IF +Y'>0
DO MAIN^TIUPEVNT(TIUBUF,1,3,X)
QUIT
+9 SET TIUD1=$GET(^TIU(8925.1,+Y,1))
SET TIUD4=$GET(^TIU(8925.1,+Y,4))
+10 SET TYPE=+Y
+11 FOR
Begin DoDot:3
+12 NEW TIUN,TIUCAP,TIUFLD,TIUREQ
SET TIUREQ=0
+13 SET TIUI=$ORDER(^TIU(8925.2,+TIUBUF,"TEXT",TIUI))
if +TIUI'>0
QUIT
+14 SET TIULINE=$GET(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
if TIULINE[TIUBGN
QUIT
+15 SET TIUCAP=$PIECE(TIULINE,":")
if TIUCAP']""
QUIT
+16 SET TIUN=$ORDER(^TIU(8925.1,+TYPE,"HEAD","B",TIUCAP,0))
+17 if +TIUN'>0
QUIT
+18 SET TIUFLD=$PIECE(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,3)
+19 if TIUFLD']""
QUIT
+20 SET TIUREQ=$PIECE(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,7)
+21 SET TIUARR(TIUFLD)=$$STRIP^TIULS($PIECE(TIULINE,":",2,99))
+22 if TIUFLD'=.001
SET TIUARR(TIUFLD)=$$TRNSFRM^TIUPEFIX(+TYPE,TIUFLD,TIUARR(TIUFLD))
+23 IF +TIUREQ
IF TIUARR(TIUFLD)=""
SET TIUARR(TIUFLD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
+24 IF $SELECT(TIUFLD=.001:1,TIUFLD=.02:1,1:0)
KILL TIUARR(TIUFLD)
End DoDot:3
if TIULINE[TIUBGN!(+TIUI'>0)
QUIT
+25 IF TIULINE[TIUBGN
Begin DoDot:3
+26 NEW TIUJ
SET TIUJ=0
+27 FOR
Begin DoDot:4
+28 SET TIUI=$ORDER(^TIU(8925.2,+TIUBUF,"TEXT",TIUI))
if +TIUI'>0
QUIT
+29 SET TIUJ=TIUJ+1
+30 SET TIUARR("TEXT",TIUJ,0)=$GET(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
+31 SET TIUARR("TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
End DoDot:4
if +TIUI'>0
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
ADDTEXT(AMIEDA,TIUX) ; File Text
+1 NEW TIUI,TIUJ
SET TIUI=0
SET TIUJ=+$PIECE($GET(^DVB(396.4,+AMIEDA,"RES",0)),U,3)
+2 FOR
SET TIUI=$ORDER(TIUX("TEXT",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+3 SET TIUJ=TIUJ+1
SET ^DVB(396.4,+AMIEDA,"RES",TIUJ,0)=$GET(TIUX("TEXT",TIUI,0))
+4 SET ^DVB(396.4,+AMIEDA,"RES",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
End DoDot:1
+5 QUIT
FILE(SUCCESS,AMIEDA,TIUX,RTYPE) ; Call FM Filer to commit updates to DB
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG
+2 SET IENS=""""_AMIEDA_","""
SET FDARR="FDA(396.4,"_IENS_")"
SET FLAGS="KE"
+3 MERGE @FDARR=TIUX
+4 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+5 IF $DATA(TIUMSG)>9
Begin DoDot:1
+6 SET SUCCESS=0_U_$GET(TIUMSG(1,"TEXT",1))
+7 DO MAIN^TIUPEVNT(TIUBUF,2,"",$PIECE($GET(^TIU(8925.1,+RTYPE,0)),U),.FDA,.TIUMSG)
End DoDot:1
+8 SET SUCCESS=AMIEDA
+9 QUIT
