APSPESG2 ;IHS/MSC/PLS - SureScripts Refill Request;30-Jul-2013 18:59;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1016**;Sep 23, 2004;Build 40
Q
;
LOADRSP(LST,IEN) ;EP to return data
N ROOT,CHKDOSE,DOSE,INST,ILST,I,ID,DLG,VAL,J,LIST
K LST
I '$D(^APSPRREQ(IEN,4.5)) D
.D DLGDEF^ORWDX1(.LIST,"PSO OERR")
.S I=0 F S I=$O(LIST(I)) Q:'I D
..I $P(LIST(I),U)="ORDERABLE" D
...N ITM
...S DLG=$P(LIST(I),U,2)
...S ITM=$$GET1^DIQ(9009033.91,IEN,1.1,"I")
...S LST(1)="~"_DLG_U_1_U_"ORDERABLE"
...S LST(2)="i"_ITM,LST(3)="e"_$$GET1^DIQ(101.43,ITM,.01)
.;ADDED FROM PREVIOUS
.N ITEM,OI,EXT,INT,DATA
.S ILST=0
.D DLGDEF^ORWDX1(.LIST,"PSO OERR")
.D GETS^DIQ(9009033.91,IEN,".01:1.9;2*;3*;4.1;7.1","E","EXT")
.D GETS^DIQ(9009033.91,IEN,".01:1.9;2*;3*;4.1;7.1","I","INT")
.S ITEM="" F S ITEM=$O(LIST(ITEM)) Q:'+ITEM D
..S DATA=$G(LIST(ITEM))
..Q:DATA=""
..S DLG=$P(DATA,U,2),INST=1,ID=$P(DATA,U,1)
..I ID="ORDERABLE" D GET(1.1,DLG,INST,ID)
..I ID="START" D NEW(DLG,INST,ID),VAL(0,0)
..I ID="URGENCY" D NEW(DLG,INST,ID),VAL(9,"ROUTINE")
..;I ID="DRUG" D GET(1.8,DLG,INST,ID)
..I ID="PICKUP" D NEW(DLG,INST,ID) D
...I $$ERXOI^APSPFNC6($$GET1^DIQ(9009033.91,IEN,1.1,"I"),2) D
....D VAL("P","PRINT")
...E D VAL("E","ELECTRONIC")
..I ID="QTY" D GET(1.4,DLG,INST,ID)
..I ID="REFILLS" D GET(1.9,DLG,INST,ID)
..I ID="SCHEDULE" D SUB(1.8,DLG,INST,ID)
..I ID="INSTR" D INSTR(DLG,INST,ID)
..I ID="ROUTE" D SUB(1.7,DLG,INST,ID)
..I ID="DAW" D GET(1.12,DLG,INST,ID)
..;I ID="DAYS" D SUB(4,DLG,INST,ID)
..;I ID="CLININD" D NEW(DLG,INST,ID)
..I ID="CLININD" D GET(7.1,DLG,INST,ID)
..I ID="CLININD2" D NEW(DLG,INST,ID)
..I ID="SNMDCNPTID" D NEW(DLG,INST,ID)
..I ID="SSREQIEN" D NEW(DLG,INST,ID),VAL(IEN,IEN)
..I ID="SSDENYRSN" D NEW(DLG,INST,ID)
..;I ID="PHARMACY",'$$ERXOI^APSPFNC6($$GET1^DIQ(9009033.91,IEN,1.1,"I"),2) D GET(1.7,DLG,INST,ID)
..I ID="PHARMACY" D GET(1.7,DLG,INST,ID)
..I ID="STRENGTH" D NEW(DLG,INST,ID)
..I ID="SIG" D SUB2(DLG,INST,ID)
..I ID="CONJ" D SUB(1.6,DLG,INST,ID)
..I ID="SUPPLY" D GET(1.5,DLG,INST,ID)
..I ID="CMF" D NEW(DLG,INST,ID)
..I ID="DOSE" D DOSE(DLG,INST,ID)
..;I ID="PI" D PI(4.1,DLG,INST,ID)
..I ID="COMMENT" D NP(4.1,DLG,INST,ID)
E D
.S ROOT="^APSPRREQ("_+IEN_",4.5)"
.S (ILST,I)=0,CHKDOSE=$$CHKDOSES^ORWDX2()
.F S I=$O(@ROOT@(I)) Q:I'>0 D
..S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
..S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
..I '$L(ID) S ID="ID"_DLG
..S VAL=$G(@ROOT@(I,1))
..I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
..S LST($$NXT)="~"_DLG_U_INST_U_ID
..I $L(VAL) D
...S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL^ORWDX2(VAL,DLG)
...I CHKDOSE D DOSEINFO^ORWDX2
..I $D(@ROOT@(I,2))>1 D
...S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D
....S LST($$NXT())="t"_$G(@ROOT@(I,2,J,0))
.I CHKDOSE D FIXDOSES^ORWDX2
Q
NEW(DLG,INST,ID) ;
S LST($$NXT)="~"_DLG_U_INST_U_ID
Q
VAL(IVAL,EVAL) ;
I $L(IVAL) D
.S LST($$NXT)="i"_IVAL,LST($$NXT)="e"_EVAL
Q
PI(FIELD,DLG,INST,ID) ;
N I,E
D NEW(DLG,INST,ID)
S I=$G(^APSPRREQ(IEN,FIELD))
S E=I
D VAL(I,E)
Q
NP(FIELD,DLG,INST,ID) ;
N I,E
D NEW(DLG,INST,ID)
S I=$G(^APSPRREQ(IEN,FIELD))
S E=I
D VAL(I,E)
Q
GET(FIELD,DLG,INST,ID) ;
N I,E
D NEW(DLG,INST,ID)
S I=$G(INT(9009033.91,IEN_",",FIELD,"I"))
S E=$G(EXT(9009033.91,IEN_",",FIELD,"E"))
I FIELD=1.9 D
.S I=$S(I>0:I-1,1:0),E=$S(E>0:E-1,1:0)
D VAL(I,E)
Q
SUB(SFIELD,DLG,INST,ID) ;
N I,E,IENS,AIEN
S IENS=0 F S IENS=$O(^APSPRREQ(IEN,2,IENS)) Q:'+IENS D
.D NEW(DLG,IENS,ID)
.S AIEN=IENS_","_IEN_","
.S I=$G(INT(9009033.912,AIEN,SFIELD,"I"))
.S E=$G(EXT(9009033.912,AIEN,SFIELD,"E"))
.D VAL(I,E)
Q
INSTR(DLG,INST,ID) ;Do instr
N I,E,IENS,AIEN
S IENS=0 F S IENS=$O(^APSPRREQ(IEN,2,IENS)) Q:'+IENS D
.D NEW(DLG,IENS,ID)
.S I=$P($G(^APSPRREQ(IEN,2,IENS,0)),"&",5)
.S E=$P($G(^APSPRREQ(IEN,2,IENS,0)),"&",5)
.D VAL(I,E)
SUB2(DLG,INST,ID) ; Do sig
N SIG
D NEW(DLG,INST,ID)
S SIG=0 F S SIG=$O(^APSPRREQ(IEN,3,SIG)) Q:'+SIG D
.S LST($$NXT)="t"_$G(^APSPRREQ(IEN,3,SIG,0))
Q
DOSE(DLG,INST,ID) ;Do dosing
N CHKDOSE,INSTR,DOSE,PSOI,DFN,CONJ,ORWDOSES,IENS
S DFN=$G(INT(9009033.91,IEN_",",1.2,"I"))
S FIELD=1.1
S OI=$G(INT(9009033.91,IEN_",",FIELD,"I"))
S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)
S IENS=0 F S IENS=$O(^APSPRREQ(IEN,2,IENS)) Q:IENS="" D
.D NEW(DLG,IENS,ID)
.S I=$G(^APSPRREQ(IEN,2,IENS,0))
.S E=$G(^APSPRREQ(IEN,2,IENS,0))
.D VAL(I,E)
;D DOSE^PSSORUTL(.ORDOSE,PSOI,"O",DFN)
;S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0
;S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" "
;S I=0 F S I=$O(ORDOSE(I)) Q:I'>0 D
;. S X=$$BLDDOSE^ORWDPS2(ORDOSE(I))
;. S ILST=ILST+1
;. S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
;. S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D
;. . S X=$$BLDDOSE^ORWDPS2(ORDOSE(I,J))
;. . S ILST=ILST+1
;. . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
Q
;
NXT() ; -- Gets index in array
S ILST=ILST+1
Q ILST
;
;Input parameters
;IEN=Internal number from APAP REFILL REQUEST file
;DFN=Patient IEN
;ORNP=Provider IEN
;ORL=IEN of location
;DLG=Defaults to PSO OERR
;STAT=Interval value of status
; 2 PROCESSED - ACCEPTED
; 3 PROCESSED - DENIED
; 5 PROCESSED - DENIED (NEW RX)
;LIST=Array of pieces to store similar to ORWDX SAVE
;REASON=Reason for denial
UPDATE(REC,IEN,DFN,ORNP,ORL,STAT,LIST,REASON,DLG) ;EP-
N IFN,ORDIALOG,ERR,NAME,FLD,FLD2,SUB
S REC=""
S DLG=$G(DLG,"PSO OERR")
S IFN=$O(^ORD(101.41,"B",DLG,""))
Q:'IFN
M ORDIALOG=LIST
D GETDLG1^ORCD(IFN)
S:STAT>-1 FDA(9009033.91,IEN_",",.03)=STAT
S FDA(9009033.91,IEN_",",.07)=$$NOW^XLFDT
S:DFN FDA(9009033.91,IEN_",",1.2)=DFN
S:ORNP FDA(9009033.91,IEN_",",1.3)=ORNP
S:ORL FDA(9009033.91,IEN_",",1.6)=ORL
S:$L($G(REASON)) FDA(9009033.91,IEN_",",4)=$G(REASON)
D RESPUPD(.ORDIALOG)
S FLD="" F S FLD=$O(ORDIALOG(FLD)) Q:FLD="" D
.S FLD2=+FLD
.I $D(ORDIALOG(FLD)) D
..S NAME=$P($G(ORDIALOG(FLD2)),U,2)
..I NAME="ORDERABLE" D TOP(1.1) Q
..I NAME="QTY" D TOP(1.4) Q
..I NAME="DRUG" D TOP(1.8) Q
..I NAME="SUPPLY" D TOP(1.5) Q
..I NAME="DAW" D TOP(1.12) Q
..I NAME="PHARMACY" D TOP(1.7) Q
..I NAME="REFILLS" D FILL(1.9) Q
..I NAME="CLININD" D TOP(7.1) Q
..I NAME="CLININD2" D TOP(7.2) Q
..I NAME="SNMDCNPTID" D TOP(7.3) Q
..;I NAME="PI" D TOP(4.1) Q
..I NAME="PI" D PI2(FLD,1) Q
..S SUB="" F S SUB=$O(LIST(FLD,SUB)) Q:SUB="" D
...I NAME="ROUTE" D SUBFLD(1.7,SUB)
...I NAME="SCHEDULE" D SUBFLD(1.8,SUB)
...I NAME="DOSE" D DOSAGE(SUB)
...I NAME="SIG" D SIG(SUB)
;When all finished file the data
D FILE^DIE("","FDA","ERR")
I $D(ERR)>0 S REC="0^Unable to Update Record" Q
E S REC=1
K FDA,ERR
Q
;Place responses into multiple
RESPUPD(ORDIALOG) ;EP- Copied from RESPONSE^ORCSAVE
N CNT,PROMPT,ITM,TYPE,VALUE
K ^APSPRREQ(IEN,4.5)
S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D
.S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
.S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
.S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D
..S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1
..S ^APSPRREQ(IEN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
..S:$L($P(ITM,U,2)) ^APSPRREQ(IEN,4.5,"ID",$P(ITM,U,2),CNT)=""
..I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0
..S:TYPE'="W" ^APSPRREQ(IEN,4.5,CNT,1)=VALUE
..M:TYPE="W" ^APSPRREQ(IEN,4.5,CNT,2)=@VALUE ; array root
S ^APSPRREQ(IEN,4.5,0)="^9009033.913A^"_CNT_U_CNT
Q
TOP(FIELD) ;Set top fields for update
N DATA
S DATA=$G(LIST(FLD,"1"))
S FDA(9009033.91,IEN_",",FIELD)=DATA
Q
FILL(FIELD) ;Set refills
;Set sub fields for update
N DATA
S DATA=$G(LIST(FLD,"1"))+1
S FDA(9009033.91,IEN_",",FIELD)=DATA
Q
SUBFLD(FIELD,SUB) N DATA,AIEN
S AIEN=+SUB_","_IEN_","
S DATA=$G(LIST(FLD,SUB))
S FDA(9009033.912,AIEN,FIELD)=DATA
Q
DOSAGE(SUB) ;Set dose fields
N DATA,AIEN,UNITS,UIEN
S DATA=$G(LIST(FLD,SUB))
S AIEN=+SUB_","_IEN_","
S FDA(9009033.912,AIEN,.01)=DATA
S FDA(9009033.912,AIEN,1.1)=$P(DATA,"&",1)
S FDA(9009033.912,AIEN,1.2)=$P(DATA,"&",3)
S UNITS=$P(DATA,"&",2)
I UNITS'="" D
.S UIEN="" S UIEN=$O(^PS(50.607,"B",UNITS,UIEN))
.I +UIEN S FDA(9009033.912,AIEN,1.3)=UIEN
S FDA(9009033.912,AIEN,1.4)=$P(DATA,"&",4)
S FDA(9009033.912,AIEN,1.9)="TAKE"
Q
SIG(SUB) ;Get sig segment
N X,DATA,ARRAY,CNT,DA,DIK,ERR,FDA2
S CNT=0
S DATA=$G(LIST(FLD,SUB))
S X=9009033.913 D DELSF(X,+IEN_",")
S X=0 S X=$O(LIST("WP",FLD,SUB,X)) Q:X="" D
.S AIEN="+1,"_IEN_","
.S FDA2(9009033.913,AIEN,.01)=$G(LIST("WP",FLD,SUB,X,0))
D UPDATE^DIE(,"FDA2","AIEN","ERR")
I $D(ERR)>0 S REC="0^Unable to update sig"
Q
PI2(FLD,SUB) ;EP-
N X,DATA,TXT
S DATA=$G(LIST(FLD,SUB))
S TXT=""
S X=0 S X=$O(LIST("WP",FLD,SUB,X)) Q:X="" D
.S TXT=TXT_$G(LIST("WP",FLD,SUB,X,0))
S FDA(9009033.91,IEN_",",4.1)=TXT
Q
DELSF(SFN,IEN) ;
N DIK,DA,LP,GBL,IEN2
S IEN2=","_IEN,DIK=$$ROOT^DILFD(SFN,IEN2),GBL=$$ROOT^DILFD(SFN,IEN2,1),DA=0
F S DA=$O(@GBL@(DA)),DA(1)=+IEN Q:'DA D ^DIK
Q
; Process a mapped SureScripts Refill Request
PROCESS(DATA,IEN) ;EP-
S DATA=$$CREATE(IEN)
Q
;
CREATE(ITEM) ; Create new OE/RR order
N HLMSG,APSPMSH,APSPPID,APSPORC,APSPRXO,APSPRXE,IEN,IENS,ID,IDIEN,DAT,DFN,PROV,UNITS,NOUN
N DUR,CONJ,VERB,SIGNOD,INSTNOD,SIG,DUPD,X,Z,ORDIALOG,NORIFN,ORVP,DIALOG,ORNP,STATUS,APSPRXO
N APSPRXE,APSPRXR,APSPORC,APSPPID,DIEN,IDIEN,DUOUT,FIL2,FIL3,FIL,LIST,LOC,ROUTE,CNT,DIR,PHARM
N CLININD,OPSIEN,SSRTEXT,DAW,MISLIST,REFIL,HLDATA,DAW,SNMDCID
N DATA,DRUG,FCNT,NOD0,NOD1,TXT,NSSRTXT
S FIL=9009033.91,FIL2=9009033.912,FIL3=9009033.913
; set up hl7 variables
S NOD0=$G(^APSPRREQ(ITEM,0))
S NOD1=$G(^APSPRREQ(ITEM,1))
Q:(NOD0="")!(NOD1="") "1 ^Entry not available"
S HLMSG=$$GHLDAT(ITEM) D SHLVARS
; get data from APSP REFILL REQUESTS FILE
D PREPPTXT^APSPES2("PTXT",ITEM)
D GETS^DIQ(FIL,ITEM,"**","IE","DATA")
S IEN=ITEM_","
S LOC=$P(NOD1,U,6)
S PHARM=$P(NOD1,U,7)
S DRUG=$P(NOD1,U,8)
S FCNT=$P(NOD1,U,9)
S DAW=$P(NOD1,U,12)
S DFN=$G(DATA(FIL,IEN,1.2,"I"))
S PROV=$G(DATA(FIL,IEN,1.3,"I"))
;S DAT("REFILLS")=$S(FCNT>0:FCNT-1,1:0)
S ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)=ITEM
D PREPPTXT^APSPES2("SSRTEXT",ITEM)
S I=0 F S I=$O(SSRTEXT(I)) Q:'I D
.S TXT=$G(SSRTEXT(I))
.S NSSRTXT(I,0)=TXT
S ORDIALOG($$PTR^ORCD("OR GTX SSREFREQ"),1)="NSSRTXT"
D BLDRSP(.ORDIALOG,ITEM)
S DIALOG=$O(^ORD(101.41,"B","PSO OERR",0))
S ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)=DRUG
S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)="E"
S ORDIALOG($$PTR^ORCD("OR GTX URGENCY"),1)=$O(^ORD(101.42,"B","ROUTINE",0))
S ORDIALOG($$PTR^ORCD("OR GTX LOCATION"),1)=LOC
S ORDIALOG($$PTR^ORCD("OR GTX DAW"),1)=DAW
S ORVP=DFN_";DPT(",ORNP=PROV
D SAVE^ORWD(.Y,DFN,PROV,$G(LOC),DIALOG,"N",.ORDIALOG)
I $G(Y) S NORIFN=$P($P($P(Y(1),U),";"),"~",2)
I '$G(NORIFN) Q "1^Order not filed. Check data and try again."
D EN^OCXOERR(DFN_U_+NORIFN_U_PROV_"^^^^^1")
S FDA(9009033.91,ITEM_",",.02)=NORIFN
S FDA(9009033.91,ITEM_",",.03)=1
S FDA(9009033.91,ITEM_",",.07)=$$NOW^XLFDT()
S FDA(9009033.91,ITEM_",",1.11)=2
D FILE^DIE(,"FDA") K FDA
Q "0^Order created."
; Display missing data elements to user.
; input - MLIST (from CHKORD), passed by reference
DISPMIS(MLIST) ;
N ITEM,LINE
S $P(LINE,"-",80)="" W !!,LINE
W !,"The following items are not defined. This order can not be created."
W !,"Please correct these items and try again."
S ITEM="" F S ITEM=$O(MLIST(ITEM)) Q:ITEM']"" D
.W !,ITEM
W !,LINE
Q
; Input: OARY - ORDIALOG passed in by reference
; MLIST - List of data elements that are missing from the order (pass by ref.), returned to calling module
CHKORD(OARY,MLIST) ;
N STAT,I,DONE,CHKITEM,CHKIEN
S STAT=1,DONE=0
F I=1:1 D Q:DONE
.S CHKITEM=$P($T(REQFLDS+I),";;",2)
.I '$L(CHKITEM) S DONE=1 Q
.S CHKIEN=$O(^ORD(101.41,"B",CHKITEM,0))
.I 'CHKIEN Q
.; if the array item doesn't exist, place it in the 'missing' array and set stat to zero
.I '$D(OARY(CHKIEN)) S MLIST(CHKITEM)=CHKIEN,STAT=0 Q
.; if the array item exists, but there is no data populated, set the 'missing' array item and stat to zero
.I $D(OARY(CHKIEN)),'$L($G(OARY(CHKIEN,1))) S MLIST(CHKITEM)=CHKIEN,STAT=0 Q
Q STAT
;
GHLDAT(IEN) ; Get HL7 message data from APSP REFILL REQUEST FILE
N HLMSG
S HLMSG=$$GET1^DIQ(9009033.91,IEN,5,"","HLDATA")
Q HLMSG
;
SHLVARS ; Set up HL segment data
N SEGTYP,VAR
F SEGTYP="MSH","PID","ORC","RXO","RXE","RXR" S VAR="APSP"_SEGTYP,@VAR="",@VAR=$$GETSEG(.HLDATA,SEGTYP)
Q
; Input: DATA - HL7 data from APSP REFILL REQUEST file
; TYPE - Message segment requested
GETSEG(DATA,TYPE) ;
N X,RET,Q
S RET="",(X,Q)=0 F S X=$O(DATA(X)) Q:'X!(Q) D
.S DAT=$G(DATA(X)) I DAT="" S RET="" Q
.I $P(DAT,"|")=TYPE S RET=DAT,Q=1 Q
Q RET
; Build ORDIALOG array for creation of order
BLDRSP(ORDIALOG,IEN) ;EP-
N LP,LP1,NOD0,INST,ITM,VAL
S LP=0 F S LP=$O(^APSPRREQ(IEN,4.5,LP)) Q:'LP D
.S NOD0=^APSPRREQ(IEN,4.5,LP,0)
.S ITM=$P(NOD0,U,2)
.S INST=$P(NOD0,U,3)
.S VAL=$G(^APSPRREQ(IEN,4.5,LP,1))
.I $D(^APSPRREQ(IEN,4.5,LP,2))>1 D
..S LP1=0 F S LP1=$O(^APSPRREQ(IEN,4.5,LP,2,LP1)) Q:'LP1 D
...S ORDIALOG("WP",ITM,INST,LP1,0)=^APSPRREQ(IEN,4.5,LP,2,LP1,0)
..S ORDIALOG(ITM,INST)="ORDIALOG(""WP"","_ITM_","_INST_")"
.E D
..S ORDIALOG(ITM,INST)=VAL
Q
REQFLDS ;
;;OR GTX ORDERABLE ITEM
;;OR GTX INSTRUCTIONS
;;OR GTX ROUTE
;;OR GTX SCHEDULE
;;OR GTX URGENCY
;;OR GTX ROUTING
;;OR GTX REFILLS
;;OR GTX DAYS SUPPLY
;;OR GTX PHARMACY
;;OR GTX DAW
;;OR GTX SSREFREQ
;;OR GTX SSRREQIEN
;;
Q
APSPESG2 ;IHS/MSC/PLS - SureScripts Refill Request;30-Jul-2013 18:59;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1016**;Sep 23, 2004;Build 40
+2 QUIT
+3 ;
LOADRSP(LST,IEN) ;EP to return data
+1 NEW ROOT,CHKDOSE,DOSE,INST,ILST,I,ID,DLG,VAL,J,LIST
+2 KILL LST
+3 IF '$DATA(^APSPRREQ(IEN,4.5))
Begin DoDot:1
+4 DO DLGDEF^ORWDX1(.LIST,"PSO OERR")
+5 SET I=0
FOR
SET I=$ORDER(LIST(I))
IF 'I
QUIT
Begin DoDot:2
+6 IF $PIECE(LIST(I),U)="ORDERABLE"
Begin DoDot:3
+7 NEW ITM
+8 SET DLG=$PIECE(LIST(I),U,2)
+9 SET ITM=$$GET1^DIQ(9009033.91,IEN,1.1,"I")
+10 SET LST(1)="~"_DLG_U_1_U_"ORDERABLE"
+11 SET LST(2)="i"_ITM
SET LST(3)="e"_$$GET1^DIQ(101.43,ITM,.01)
End DoDot:3
End DoDot:2
+12 ;ADDED FROM PREVIOUS
+13 NEW ITEM,OI,EXT,INT,DATA
+14 SET ILST=0
+15 DO DLGDEF^ORWDX1(.LIST,"PSO OERR")
+16 DO GETS^DIQ(9009033.91,IEN,".01:1.9;2*;3*;4.1;7.1","E","EXT")
+17 DO GETS^DIQ(9009033.91,IEN,".01:1.9;2*;3*;4.1;7.1","I","INT")
+18 SET ITEM=""
FOR
SET ITEM=$ORDER(LIST(ITEM))
IF '+ITEM
QUIT
Begin DoDot:2
+19 SET DATA=$GET(LIST(ITEM))
+20 IF DATA=""
QUIT
+21 SET DLG=$PIECE(DATA,U,2)
SET INST=1
SET ID=$PIECE(DATA,U,1)
+22 IF ID="ORDERABLE"
DO GET(1.1,DLG,INST,ID)
+23 IF ID="START"
DO NEW(DLG,INST,ID)
DO VAL(0,0)
+24 IF ID="URGENCY"
DO NEW(DLG,INST,ID)
DO VAL(9,"ROUTINE")
+25 ;I ID="DRUG" D GET(1.8,DLG,INST,ID)
+26 IF ID="PICKUP"
DO NEW(DLG,INST,ID)
Begin DoDot:3
+27 IF $$ERXOI^APSPFNC6($$GET1^DIQ(9009033.91,IEN,1.1,"I"),2)
Begin DoDot:4
+28 DO VAL("P","PRINT")
End DoDot:4
+29 IF '$TEST
DO VAL("E","ELECTRONIC")
End DoDot:3
+30 IF ID="QTY"
DO GET(1.4,DLG,INST,ID)
+31 IF ID="REFILLS"
DO GET(1.9,DLG,INST,ID)
+32 IF ID="SCHEDULE"
DO SUB(1.8,DLG,INST,ID)
+33 IF ID="INSTR"
DO INSTR(DLG,INST,ID)
+34 IF ID="ROUTE"
DO SUB(1.7,DLG,INST,ID)
+35 IF ID="DAW"
DO GET(1.12,DLG,INST,ID)
+36 ;I ID="DAYS" D SUB(4,DLG,INST,ID)
+37 ;I ID="CLININD" D NEW(DLG,INST,ID)
+38 IF ID="CLININD"
DO GET(7.1,DLG,INST,ID)
+39 IF ID="CLININD2"
DO NEW(DLG,INST,ID)
+40 IF ID="SNMDCNPTID"
DO NEW(DLG,INST,ID)
+41 IF ID="SSREQIEN"
DO NEW(DLG,INST,ID)
DO VAL(IEN,IEN)
+42 IF ID="SSDENYRSN"
DO NEW(DLG,INST,ID)
+43 ;I ID="PHARMACY",'$$ERXOI^APSPFNC6($$GET1^DIQ(9009033.91,IEN,1.1,"I"),2) D GET(1.7,DLG,INST,ID)
+44 IF ID="PHARMACY"
DO GET(1.7,DLG,INST,ID)
+45 IF ID="STRENGTH"
DO NEW(DLG,INST,ID)
+46 IF ID="SIG"
DO SUB2(DLG,INST,ID)
+47 IF ID="CONJ"
DO SUB(1.6,DLG,INST,ID)
+48 IF ID="SUPPLY"
DO GET(1.5,DLG,INST,ID)
+49 IF ID="CMF"
DO NEW(DLG,INST,ID)
+50 IF ID="DOSE"
DO DOSE(DLG,INST,ID)
+51 ;I ID="PI" D PI(4.1,DLG,INST,ID)
+52 IF ID="COMMENT"
DO NP(4.1,DLG,INST,ID)
End DoDot:2
End DoDot:1
+53 IF '$TEST
Begin DoDot:1
+54 SET ROOT="^APSPRREQ("_+IEN_",4.5)"
+55 SET (ILST,I)=0
SET CHKDOSE=$$CHKDOSES^ORWDX2()
+56 FOR
SET I=$ORDER(@ROOT@(I))
IF I'>0
QUIT
Begin DoDot:2
+57 SET DLG=$PIECE(@ROOT@(I,0),U,2)
SET INST=$PIECE(^(0),U,3)
+58 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
+59 IF '$LENGTH(ID)
SET ID="ID"_DLG
+60 SET VAL=$GET(@ROOT@(I,1))
+61 IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE"
SET ID="ADDITIVE"
+62 SET LST($$NXT)="~"_DLG_U_INST_U_ID
+63 IF $LENGTH(VAL)
Begin DoDot:3
+64 SET LST($$NXT)="i"_VAL
SET LST($$NXT)="e"_$$EXTVAL^ORWDX2(VAL,DLG)
+65 IF CHKDOSE
DO DOSEINFO^ORWDX2
End DoDot:3
+66 IF $DATA(@ROOT@(I,2))>1
Begin DoDot:3
+67 SET J=0
FOR
SET J=$ORDER(@ROOT@(I,2,J))
IF J'>0
QUIT
Begin DoDot:4
+68 SET LST($$NXT())="t"_$GET(@ROOT@(I,2,J,0))
End DoDot:4
End DoDot:3
End DoDot:2
+69 IF CHKDOSE
DO FIXDOSES^ORWDX2
End DoDot:1
+70 QUIT
NEW(DLG,INST,ID) ;
+1 SET LST($$NXT)="~"_DLG_U_INST_U_ID
+2 QUIT
VAL(IVAL,EVAL) ;
+1 IF $LENGTH(IVAL)
Begin DoDot:1
+2 SET LST($$NXT)="i"_IVAL
SET LST($$NXT)="e"_EVAL
End DoDot:1
+3 QUIT
PI(FIELD,DLG,INST,ID) ;
+1 NEW I,E
+2 DO NEW(DLG,INST,ID)
+3 SET I=$GET(^APSPRREQ(IEN,FIELD))
+4 SET E=I
+5 DO VAL(I,E)
+6 QUIT
NP(FIELD,DLG,INST,ID) ;
+1 NEW I,E
+2 DO NEW(DLG,INST,ID)
+3 SET I=$GET(^APSPRREQ(IEN,FIELD))
+4 SET E=I
+5 DO VAL(I,E)
+6 QUIT
GET(FIELD,DLG,INST,ID) ;
+1 NEW I,E
+2 DO NEW(DLG,INST,ID)
+3 SET I=$GET(INT(9009033.91,IEN_",",FIELD,"I"))
+4 SET E=$GET(EXT(9009033.91,IEN_",",FIELD,"E"))
+5 IF FIELD=1.9
Begin DoDot:1
+6 SET I=$SELECT(I>0:I-1,1:0)
SET E=$SELECT(E>0:E-1,1:0)
End DoDot:1
+7 DO VAL(I,E)
+8 QUIT
SUB(SFIELD,DLG,INST,ID) ;
+1 NEW I,E,IENS,AIEN
+2 SET IENS=0
FOR
SET IENS=$ORDER(^APSPRREQ(IEN,2,IENS))
IF '+IENS
QUIT
Begin DoDot:1
+3 DO NEW(DLG,IENS,ID)
+4 SET AIEN=IENS_","_IEN_","
+5 SET I=$GET(INT(9009033.912,AIEN,SFIELD,"I"))
+6 SET E=$GET(EXT(9009033.912,AIEN,SFIELD,"E"))
+7 DO VAL(I,E)
End DoDot:1
+8 QUIT
INSTR(DLG,INST,ID) ;Do instr
+1 NEW I,E,IENS,AIEN
+2 SET IENS=0
FOR
SET IENS=$ORDER(^APSPRREQ(IEN,2,IENS))
IF '+IENS
QUIT
Begin DoDot:1
+3 DO NEW(DLG,IENS,ID)
+4 SET I=$PIECE($GET(^APSPRREQ(IEN,2,IENS,0)),"&",5)
+5 SET E=$PIECE($GET(^APSPRREQ(IEN,2,IENS,0)),"&",5)
+6 DO VAL(I,E)
End DoDot:1
SUB2(DLG,INST,ID) ; Do sig
+1 NEW SIG
+2 DO NEW(DLG,INST,ID)
+3 SET SIG=0
FOR
SET SIG=$ORDER(^APSPRREQ(IEN,3,SIG))
IF '+SIG
QUIT
Begin DoDot:1
+4 SET LST($$NXT)="t"_$G(^APSPRREQ(IEN,3,SIG,0))
End DoDot:1
+5 QUIT
DOSE(DLG,INST,ID) ;Do dosing
+1 NEW CHKDOSE,INSTR,DOSE,PSOI,DFN,CONJ,ORWDOSES,IENS
+2 SET DFN=$GET(INT(9009033.91,IEN_",",1.2,"I"))
+3 SET FIELD=1.1
+4 SET OI=$GET(INT(9009033.91,IEN_",",FIELD,"I"))
+5 SET PSOI=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
+6 SET IENS=0
FOR
SET IENS=$ORDER(^APSPRREQ(IEN,2,IENS))
IF IENS=""
QUIT
Begin DoDot:1
+7 DO NEW(DLG,IENS,ID)
+8 SET I=$GET(^APSPRREQ(IEN,2,IENS,0))
+9 SET E=$GET(^APSPRREQ(IEN,2,IENS,0))
+10 DO VAL(I,E)
End DoDot:1
+11 ;D DOSE^PSSORUTL(.ORDOSE,PSOI,"O",DFN)
+12 ;S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0
+13 ;S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" "
+14 ;S I=0 F S I=$O(ORDOSE(I)) Q:I'>0 D
+15 ;. S X=$$BLDDOSE^ORWDPS2(ORDOSE(I))
+16 ;. S ILST=ILST+1
+17 ;. S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
+18 ;. S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D
+19 ;. . S X=$$BLDDOSE^ORWDPS2(ORDOSE(I,J))
+20 ;. . S ILST=ILST+1
+21 ;. . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
+22 QUIT
+23 ;
NXT() ; -- Gets index in array
+1 SET ILST=ILST+1
+2 QUIT ILST
+3 ;
+4 ;Input parameters
+5 ;IEN=Internal number from APAP REFILL REQUEST file
+6 ;DFN=Patient IEN
+7 ;ORNP=Provider IEN
+8 ;ORL=IEN of location
+9 ;DLG=Defaults to PSO OERR
+10 ;STAT=Interval value of status
+11 ; 2 PROCESSED - ACCEPTED
+12 ; 3 PROCESSED - DENIED
+13 ; 5 PROCESSED - DENIED (NEW RX)
+14 ;LIST=Array of pieces to store similar to ORWDX SAVE
+15 ;REASON=Reason for denial
UPDATE(REC,IEN,DFN,ORNP,ORL,STAT,LIST,REASON,DLG) ;EP-
+1 NEW IFN,ORDIALOG,ERR,NAME,FLD,FLD2,SUB
+2 SET REC=""
+3 SET DLG=$GET(DLG,"PSO OERR")
+4 SET IFN=$ORDER(^ORD(101.41,"B",DLG,""))
+5 IF 'IFN
QUIT
+6 MERGE ORDIALOG=LIST
+7 DO GETDLG1^ORCD(IFN)
+8 IF STAT>-1
SET FDA(9009033.91,IEN_",",.03)=STAT
+9 SET FDA(9009033.91,IEN_",",.07)=$$NOW^XLFDT
+10 IF DFN
SET FDA(9009033.91,IEN_",",1.2)=DFN
+11 IF ORNP
SET FDA(9009033.91,IEN_",",1.3)=ORNP
+12 IF ORL
SET FDA(9009033.91,IEN_",",1.6)=ORL
+13 IF $LENGTH($GET(REASON))
SET FDA(9009033.91,IEN_",",4)=$GET(REASON)
+14 DO RESPUPD(.ORDIALOG)
+15 SET FLD=""
FOR
SET FLD=$ORDER(ORDIALOG(FLD))
IF FLD=""
QUIT
Begin DoDot:1
+16 SET FLD2=+FLD
+17 IF $DATA(ORDIALOG(FLD))
Begin DoDot:2
+18 SET NAME=$PIECE($GET(ORDIALOG(FLD2)),U,2)
+19 IF NAME="ORDERABLE"
DO TOP(1.1)
QUIT
+20 IF NAME="QTY"
DO TOP(1.4)
QUIT
+21 IF NAME="DRUG"
DO TOP(1.8)
QUIT
+22 IF NAME="SUPPLY"
DO TOP(1.5)
QUIT
+23 IF NAME="DAW"
DO TOP(1.12)
QUIT
+24 IF NAME="PHARMACY"
DO TOP(1.7)
QUIT
+25 IF NAME="REFILLS"
DO FILL(1.9)
QUIT
+26 IF NAME="CLININD"
DO TOP(7.1)
QUIT
+27 IF NAME="CLININD2"
DO TOP(7.2)
QUIT
+28 IF NAME="SNMDCNPTID"
DO TOP(7.3)
QUIT
+29 ;I NAME="PI" D TOP(4.1) Q
+30 IF NAME="PI"
DO PI2(FLD,1)
QUIT
+31 SET SUB=""
FOR
SET SUB=$ORDER(LIST(FLD,SUB))
IF SUB=""
QUIT
Begin DoDot:3
+32 IF NAME="ROUTE"
DO SUBFLD(1.7,SUB)
+33 IF NAME="SCHEDULE"
DO SUBFLD(1.8,SUB)
+34 IF NAME="DOSE"
DO DOSAGE(SUB)
+35 IF NAME="SIG"
DO SIG(SUB)
End DoDot:3
End DoDot:2
End DoDot:1
+36 ;When all finished file the data
+37 DO FILE^DIE("","FDA","ERR")
+38 IF $DATA(ERR)>0
SET REC="0^Unable to Update Record"
QUIT
+39 IF '$TEST
SET REC=1
+40 KILL FDA,ERR
+41 QUIT
+42 ;Place responses into multiple
RESPUPD(ORDIALOG) ;EP- Copied from RESPONSE^ORCSAVE
+1 NEW CNT,PROMPT,ITM,TYPE,VALUE
+2 KILL ^APSPRREQ(IEN,4.5)
+3 SET (PROMPT,CNT)=0
FOR
SET PROMPT=$ORDER(ORDIALOG(PROMPT))
IF PROMPT'>0
QUIT
Begin DoDot:1
+4 SET ITM=$GET(ORDIALOG(PROMPT))
IF 'ITM
QUIT
+5 SET TYPE=$EXTRACT($GET(ORDIALOG(PROMPT,0)))
IF '$LENGTH(TYPE)
QUIT
+6 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
IF INST'>0
QUIT
Begin DoDot:2
+7 SET VALUE=$GET(ORDIALOG(PROMPT,INST))
IF VALUE=""
QUIT
SET CNT=CNT+1
+8 SET ^APSPRREQ(IEN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$PIECE(ITM,U,2)
+9 IF $LENGTH($PIECE(ITM,U,2))
SET ^APSPRREQ(IEN,4.5,"ID",$PIECE(ITM,U,2),CNT)=""
+10 IF VALUE<1
IF TYPE="N"
SET VALUE=0_+VALUE
IF VALUE="00"
SET VALUE=0
+11 IF TYPE'="W"
SET ^APSPRREQ(IEN,4.5,CNT,1)=VALUE
+12 ; array root
IF TYPE="W"
MERGE ^APSPRREQ(IEN,4.5,CNT,2)=@VALUE
End DoDot:2
End DoDot:1
+13 SET ^APSPRREQ(IEN,4.5,0)="^9009033.913A^"_CNT_U_CNT
+14 QUIT
TOP(FIELD) ;Set top fields for update
+1 NEW DATA
+2 SET DATA=$GET(LIST(FLD,"1"))
+3 SET FDA(9009033.91,IEN_",",FIELD)=DATA
+4 QUIT
FILL(FIELD) ;Set refills
+1 ;Set sub fields for update
+2 NEW DATA
+3 SET DATA=$GET(LIST(FLD,"1"))+1
+4 SET FDA(9009033.91,IEN_",",FIELD)=DATA
+5 QUIT
SUBFLD(FIELD,SUB) NEW DATA,AIEN
+1 SET AIEN=+SUB_","_IEN_","
+2 SET DATA=$GET(LIST(FLD,SUB))
+3 SET FDA(9009033.912,AIEN,FIELD)=DATA
+4 QUIT
DOSAGE(SUB) ;Set dose fields
+1 NEW DATA,AIEN,UNITS,UIEN
+2 SET DATA=$GET(LIST(FLD,SUB))
+3 SET AIEN=+SUB_","_IEN_","
+4 SET FDA(9009033.912,AIEN,.01)=DATA
+5 SET FDA(9009033.912,AIEN,1.1)=$PIECE(DATA,"&",1)
+6 SET FDA(9009033.912,AIEN,1.2)=$PIECE(DATA,"&",3)
+7 SET UNITS=$PIECE(DATA,"&",2)
+8 IF UNITS'=""
Begin DoDot:1
+9 SET UIEN=""
SET UIEN=$ORDER(^PS(50.607,"B",UNITS,UIEN))
+10 IF +UIEN
SET FDA(9009033.912,AIEN,1.3)=UIEN
End DoDot:1
+11 SET FDA(9009033.912,AIEN,1.4)=$PIECE(DATA,"&",4)
+12 SET FDA(9009033.912,AIEN,1.9)="TAKE"
+13 QUIT
SIG(SUB) ;Get sig segment
+1 NEW X,DATA,ARRAY,CNT,DA,DIK,ERR,FDA2
+2 SET CNT=0
+3 SET DATA=$GET(LIST(FLD,SUB))
+4 SET X=9009033.913
DO DELSF(X,+IEN_",")
+5 SET X=0
SET X=$ORDER(LIST("WP",FLD,SUB,X))
IF X=""
QUIT
Begin DoDot:1
+6 SET AIEN="+1,"_IEN_","
+7 SET FDA2(9009033.913,AIEN,.01)=$GET(LIST("WP",FLD,SUB,X,0))
End DoDot:1
+8 DO UPDATE^DIE(,"FDA2","AIEN","ERR")
+9 IF $DATA(ERR)>0
SET REC="0^Unable to update sig"
+10 QUIT
PI2(FLD,SUB) ;EP-
+1 NEW X,DATA,TXT
+2 SET DATA=$GET(LIST(FLD,SUB))
+3 SET TXT=""
+4 SET X=0
SET X=$ORDER(LIST("WP",FLD,SUB,X))
IF X=""
QUIT
Begin DoDot:1
+5 SET TXT=TXT_$GET(LIST("WP",FLD,SUB,X,0))
End DoDot:1
+6 SET FDA(9009033.91,IEN_",",4.1)=TXT
+7 QUIT
DELSF(SFN,IEN) ;
+1 NEW DIK,DA,LP,GBL,IEN2
+2 SET IEN2=","_IEN
SET DIK=$$ROOT^DILFD(SFN,IEN2)
SET GBL=$$ROOT^DILFD(SFN,IEN2,1)
SET DA=0
+3 FOR
SET DA=$ORDER(@GBL@(DA))
SET DA(1)=+IEN
IF 'DA
QUIT
DO ^DIK
+4 QUIT
+5 ; Process a mapped SureScripts Refill Request
PROCESS(DATA,IEN) ;EP-
+1 SET DATA=$$CREATE(IEN)
+2 QUIT
+3 ;
CREATE(ITEM) ; Create new OE/RR order
+1 NEW HLMSG,APSPMSH,APSPPID,APSPORC,APSPRXO,APSPRXE,IEN,IENS,ID,IDIEN,DAT,DFN,PROV,UNITS,NOUN
+2 NEW DUR,CONJ,VERB,SIGNOD,INSTNOD,SIG,DUPD,X,Z,ORDIALOG,NORIFN,ORVP,DIALOG,ORNP,STATUS,APSPRXO
+3 NEW APSPRXE,APSPRXR,APSPORC,APSPPID,DIEN,IDIEN,DUOUT,FIL2,FIL3,FIL,LIST,LOC,ROUTE,CNT,DIR,PHARM
+4 NEW CLININD,OPSIEN,SSRTEXT,DAW,MISLIST,REFIL,HLDATA,DAW,SNMDCID
+5 NEW DATA,DRUG,FCNT,NOD0,NOD1,TXT,NSSRTXT
+6 SET FIL=9009033.91
SET FIL2=9009033.912
SET FIL3=9009033.913
+7 ; set up hl7 variables
+8 SET NOD0=$GET(^APSPRREQ(ITEM,0))
+9 SET NOD1=$GET(^APSPRREQ(ITEM,1))
+10 IF (NOD0="")!(NOD1="")
QUIT "1 ^Entry not available"
+11 SET HLMSG=$$GHLDAT(ITEM)
DO SHLVARS
+12 ; get data from APSP REFILL REQUESTS FILE
+13 DO PREPPTXT^APSPES2("PTXT",ITEM)
+14 DO GETS^DIQ(FIL,ITEM,"**","IE","DATA")
+15 SET IEN=ITEM_","
+16 SET LOC=$PIECE(NOD1,U,6)
+17 SET PHARM=$PIECE(NOD1,U,7)
+18 SET DRUG=$PIECE(NOD1,U,8)
+19 SET FCNT=$PIECE(NOD1,U,9)
+20 SET DAW=$PIECE(NOD1,U,12)
+21 SET DFN=$GET(DATA(FIL,IEN,1.2,"I"))
+22 SET PROV=$GET(DATA(FIL,IEN,1.3,"I"))
+23 ;S DAT("REFILLS")=$S(FCNT>0:FCNT-1,1:0)
+24 SET ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)=ITEM
+25 DO PREPPTXT^APSPES2("SSRTEXT",ITEM)
+26 SET I=0
FOR
SET I=$ORDER(SSRTEXT(I))
IF 'I
QUIT
Begin DoDot:1
+27 SET TXT=$GET(SSRTEXT(I))
+28 SET NSSRTXT(I,0)=TXT
End DoDot:1
+29 SET ORDIALOG($$PTR^ORCD("OR GTX SSREFREQ"),1)="NSSRTXT"
+30 DO BLDRSP(.ORDIALOG,ITEM)
+31 SET DIALOG=$ORDER(^ORD(101.41,"B","PSO OERR",0))
+32 SET ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)=DRUG
+33 SET ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)="E"
+34 SET ORDIALOG($$PTR^ORCD("OR GTX URGENCY"),1)=$ORDER(^ORD(101.42,"B","ROUTINE",0))
+35 SET ORDIALOG($$PTR^ORCD("OR GTX LOCATION"),1)=LOC
+36 SET ORDIALOG($$PTR^ORCD("OR GTX DAW"),1)=DAW
+37 SET ORVP=DFN_";DPT("
SET ORNP=PROV
+38 DO SAVE^ORWD(.Y,DFN,PROV,$GET(LOC),DIALOG,"N",.ORDIALOG)
+39 IF $GET(Y)
SET NORIFN=$PIECE($PIECE($PIECE(Y(1),U),";"),"~",2)
+40 IF '$GET(NORIFN)
QUIT "1^Order not filed. Check data and try again."
+41 DO EN^OCXOERR(DFN_U_+NORIFN_U_PROV_"^^^^^1")
+42 SET FDA(9009033.91,ITEM_",",.02)=NORIFN
+43 SET FDA(9009033.91,ITEM_",",.03)=1
+44 SET FDA(9009033.91,ITEM_",",.07)=$$NOW^XLFDT()
+45 SET FDA(9009033.91,ITEM_",",1.11)=2
+46 DO FILE^DIE(,"FDA")
KILL FDA
+47 QUIT "0^Order created."
+48 ; Display missing data elements to user.
+49 ; input - MLIST (from CHKORD), passed by reference
DISPMIS(MLIST) ;
+1 NEW ITEM,LINE
+2 SET $PIECE(LINE,"-",80)=""
WRITE !!,LINE
+3 WRITE !,"The following items are not defined. This order can not be created."
+4 WRITE !,"Please correct these items and try again."
+5 SET ITEM=""
FOR
SET ITEM=$ORDER(MLIST(ITEM))
IF ITEM']""
QUIT
Begin DoDot:1
+6 WRITE !,ITEM
End DoDot:1
+7 WRITE !,LINE
+8 QUIT
+9 ; Input: OARY - ORDIALOG passed in by reference
+10 ; MLIST - List of data elements that are missing from the order (pass by ref.), returned to calling module
CHKORD(OARY,MLIST) ;
+1 NEW STAT,I,DONE,CHKITEM,CHKIEN
+2 SET STAT=1
SET DONE=0
+3 FOR I=1:1
Begin DoDot:1
+4 SET CHKITEM=$PIECE($TEXT(REQFLDS+I),";;",2)
+5 IF '$LENGTH(CHKITEM)
SET DONE=1
QUIT
+6 SET CHKIEN=$ORDER(^ORD(101.41,"B",CHKITEM,0))
+7 IF 'CHKIEN
QUIT
+8 ; if the array item doesn't exist, place it in the 'missing' array and set stat to zero
+9 IF '$DATA(OARY(CHKIEN))
SET MLIST(CHKITEM)=CHKIEN
SET STAT=0
QUIT
+10 ; if the array item exists, but there is no data populated, set the 'missing' array item and stat to zero
+11 IF $DATA(OARY(CHKIEN))
IF '$LENGTH($GET(OARY(CHKIEN,1)))
SET MLIST(CHKITEM)=CHKIEN
SET STAT=0
QUIT
End DoDot:1
IF DONE
QUIT
+12 QUIT STAT
+13 ;
GHLDAT(IEN) ; Get HL7 message data from APSP REFILL REQUEST FILE
+1 NEW HLMSG
+2 SET HLMSG=$$GET1^DIQ(9009033.91,IEN,5,"","HLDATA")
+3 QUIT HLMSG
+4 ;
SHLVARS ; Set up HL segment data
+1 NEW SEGTYP,VAR
+2 FOR SEGTYP="MSH","PID","ORC","RXO","RXE","RXR"
SET VAR="APSP"_SEGTYP
SET @VAR=""
SET @VAR=$$GETSEG(.HLDATA,SEGTYP)
+3 QUIT
+4 ; Input: DATA - HL7 data from APSP REFILL REQUEST file
+5 ; TYPE - Message segment requested
GETSEG(DATA,TYPE) ;
+1 NEW X,RET,Q
+2 SET RET=""
SET (X,Q)=0
FOR
SET X=$ORDER(DATA(X))
IF 'X!(Q)
QUIT
Begin DoDot:1
+3 SET DAT=$GET(DATA(X))
IF DAT=""
SET RET=""
QUIT
+4 IF $PIECE(DAT,"|")=TYPE
SET RET=DAT
SET Q=1
QUIT
End DoDot:1
+5 QUIT RET
+6 ; Build ORDIALOG array for creation of order
BLDRSP(ORDIALOG,IEN) ;EP-
+1 NEW LP,LP1,NOD0,INST,ITM,VAL
+2 SET LP=0
FOR
SET LP=$ORDER(^APSPRREQ(IEN,4.5,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET NOD0=^APSPRREQ(IEN,4.5,LP,0)
+4 SET ITM=$PIECE(NOD0,U,2)
+5 SET INST=$PIECE(NOD0,U,3)
+6 SET VAL=$GET(^APSPRREQ(IEN,4.5,LP,1))
+7 IF $DATA(^APSPRREQ(IEN,4.5,LP,2))>1
Begin DoDot:2
+8 SET LP1=0
FOR
SET LP1=$ORDER(^APSPRREQ(IEN,4.5,LP,2,LP1))
IF 'LP1
QUIT
Begin DoDot:3
+9 SET ORDIALOG("WP",ITM,INST,LP1,0)=^APSPRREQ(IEN,4.5,LP,2,LP1,0)
End DoDot:3
+10 SET ORDIALOG(ITM,INST)="ORDIALOG(""WP"","_ITM_","_INST_")"
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 SET ORDIALOG(ITM,INST)=VAL
End DoDot:2
End DoDot:1
+13 QUIT
REQFLDS ;
+1 ;;OR GTX ORDERABLE ITEM
+2 ;;OR GTX INSTRUCTIONS
+3 ;;OR GTX ROUTE
+4 ;;OR GTX SCHEDULE
+5 ;;OR GTX URGENCY
+6 ;;OR GTX ROUTING
+7 ;;OR GTX REFILLS
+8 ;;OR GTX DAYS SUPPLY
+9 ;;OR GTX PHARMACY
+10 ;;OR GTX DAW
+11 ;;OR GTX SSREFREQ
+12 ;;OR GTX SSRREQIEN
+13 ;;
+14 QUIT
