Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSPESLM

APSPESLM.m

Go to the documentation of this file. 
  1. APSPESLM ;IHS/BWF - Process entries from APSP REFILL REQUEST file ;23-Jun-2009 15:30;SM
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;**1008**;Sep 23,2004
  1. MAP ; Map data values
  1.  N ITEM,HLMSG,QTY,PROV,DRUG,I,J,K,QUIT,FIL,FLD,FLDDAT,FDAT,FLDLST,RES
  1.  N PAT,INST,DOS,HFIL,HLFDAT,DONE,DIC,SIGIEN,SIEN,Y,X,APSPMSH,APSPPID,APSPORC
  1.  N APSPRXO,APSPRXE,UPD,SCHED,DUR,CONJ,USCHDUR,FLDS,DLM,SCHITEM,MEDUNITS,REFILLS
  1.  N SCHARY,HLECH,INTERVAL,PROVDAT,DUR,TOTDUR,NEXT,SCHUPD,SN,STR,NOUN,POP
  1.  N DOSARY,DIR,SCNT,DSEL,DEFRTE,DEFSCH,SIGDAT,HLOC
  1.  S DLM="|"
  1.  I '$O(@VALMAR@(0)) D BACK^APSPESLP Q
  1.  S ITEM=$$SELITEM^APSPESLP() I 'ITEM!(ITEM["^") D BACK^APSPESLP Q
  1.  ;L +^APSPRREQ(ITEM)
  1.  S HLOC=$$GET1^DIQ(9009033,$G(PSOSITE),317,"I")
  1.  I 'HLOC D ORDLOC,BACK^APSPESLP Q
  1.  ; if the hospital location is defined, then set it into field 1.6 and continue.
  1.  S DR="1.6///^S X=$G(HLOC)",DIE="^APSPRREQ(",DA=ITEM D ^DIE
  1.  I '$$GET1^DIQ(9009033.91,ITEM,1.6,"I") D ORDLOC,BACK^APSPESLP Q
  1.  S HLECH=$P($G(APSPMSH),"|",2) I '$L(HLECH) S HLECH="^~\&"
  1.  F I=1:1:4 D
  1.  .S HLECH(I)=$E(HLECH,I)
  1.  ; Get HL7 data from the file and set up variables for the data
  1.  S HLMSG=$$GHLDAT^APSPESLP(ITEM) D SHLVARS^APSPESLP
  1.  S PAT=$$PATNAME^APSPESLP(APSPPID) I '$L(PAT) S PAT="**UNKNOWN**"
  1.  S QTY=+$P(APSPRXO,DLM,12),PROVDAT=$P(APSPORC,DLM,13),PROV=$P(PROVDAT,HLECH(1),2)_","_$P(PROVDAT,HLECH(1),3)
  1.  S DRUG=$P($P($G(APSPRXO),DLM,2),U,2),INST=$P($P($G(APSPRXO),DLM,7),U,2)
  1.  S STR=$P($G(APSPRXO),DLM,3),UNITS=$P($P($G(APSPRXO),DLM,5),HLECH(1),2),ROUTE=$P($G(APSPRXR),DLM,2)
  1.  S NOUN=$P($G(APSPRXO),DLM,6) I $L(NOUN) S NOUN=$O(^APSPNCP(9009033.7,"B",NOUN,0)),NOUN=$$GET1^DIQ(9009033.7,NOUN,1,"E")
  1.  S USCHDUR=$P($G(APSPORC),DLM,8),MEDUNITS=$P($P($G(APSPRXO),DLM,20),HLECH(1),2)
  1.  S REFILLS=0
  1.  S PHARM=$$GET1^DIQ(9009033.91,ITEM,1.7,"E")
  1.  S SIGDAT=$P($P(APSPRXO,"|",8),"^",2)
  1.  S HFIL=9009033.91
  1.  S HLFDAT(HFIL,1.1)="",HLFDAT(HFIL,1.2)=PAT,HLFDAT(HFIL,1.3)=PROV,HLFDAT(HFIL,1.4)=QTY
  1.  ; Duration is currently not gathered due to
  1.  S HFIL=9009033.912
  1.  S HLFDAT(HFIL,3)=NOUN
  1.  S HLFDAT(HFIL,.01)=MEDUNITS
  1.  S DONE=0
  1.  F I=1:1 D  Q:DONE
  1.  .S SCHITEM=$P(USCHDUR,HLECH(2),I)
  1.  .I '$L(SCHITEM) S DONE=1 Q
  1.  .S SCHUPD=$P(SCHITEM,HLECH(1)) I 'SCHUPD S SCHUPD=1
  1.  .S INTERVAL=$P(SCHITEM,HLECH(1),2),DUR=$P(SCHITEM,HLECH(1),3),CONJ=$P(SCHITEM,HLECH(1),9)
  1.  .S SCHARY(I)=SCHUPD_U_INTERVAL_U_DUR_U_CONJ
  1.  .S TOTDUR=$G(TOTDUR)+DUR
  1.  .; This may be used in the future, but for now it will not.
  1.  .;S HLFDAT(HFIL,I,.01)="",HLFDAT(HFIL,I,1)="",HLFDAT(HFIL,I,.01)=UNITS
  1.  .; FIELD 3 IS NOUN, AND FIELD 8 IS VERB
  1.  .;S HLFDAT(HFIL,I,3)="",HLFDAT(HFIL,I,4)=DUR,HLFDAT(HFIL,I,5)=CONJ
  1.  .;S HLFDAT(HFIL,I,6)=ROUTE,HLFDAT(HFIL,I,7)=INTERVAL,HLFDAT(HFIL,I,8)=""
  1.  S HLFDAT(9009033.91,1.5)=$G(TOTDUR)
  1.  S HFIL=9009033.912
  1.  S HLFDAT(9009033.913,.01)=$P($P(APSPRXO,DLM,8),HLECH(1),2)
  1.  D FULL^VALM1
  1.  D DISPHL7^APSPESLP(PAT,QTY,PROV,DRUG,INST,STR,UNITS,ROUTE,NOUN,.SCHARY,MEDUNITS,REFILLS,PHARM,SIGDAT,.HLFDAT)
  1.  W !
  1.  D BLDARY^APSPESLP(.FLDLST)
  1. OITEM ; Orderable item
  1.  N DONE
  1.  S (POP,DONE)=0
  1.  S FILOI=$$GET1^DIQ(9009033.91,ITEM,1.1,"E")
  1.  S ORDDEF=$S(FILOI]"":FILOI,1:HLFDAT(9009033.91,1.1))
  1.  S ORDITEM=$$DIR^APSPUTIL("Pr^101.43:AEMQ,","Medication",ORDDEF,,.POP) I POP D BACK^APSPESLP Q
  1.  S DR="1.1///^S X=+ORDITEM",DIE="^APSPRREQ(",DA=ITEM D ^DIE
  1.  ; update the status to reflect that the mapping process has begun.
  1.  S FDA(9009033.91,ITEM_",",.03)=4 D FILE^DIE(,"FDA") K FDA
  1.  S CDOSE=$$DIRYN^APSPUTIL("Complex Dose","NO",,.POP)
  1.  ; if complex dose is indicated as no, check the multiple for more than one entry. if there is more than one, deal with it
  1.  I 'CDOSE D
  1.  .S I=0 F  S I=$O(^APSPRREQ(ITEM,2,I)) Q:'I  D
  1.  ..S SCNT=$G(SCNT)+1
  1.  .I $G(SCNT)>1 D
  1.  ..W !,"There is more than one dose defined."
  1.  ..S DELDOSES=$$DIRYN^APSPUTIL("Delete existing Dosing information","NO",,.POP)
  1.  ..I DELDOSES D  Q
  1.  ...S J=0 F  S J=$O(^APSPRREQ(ITEM,2,J)) Q:'J  D
  1.  ....S FDA(9009033.912,J_","_ITEM_",",.01)="@"
  1.  ...D FILE^DIE(,"FDA")
  1.  ..S CDOSE=1
  1.  ; If complex dose is indicated, loop and allow for multiple dosing instructions.
  1.  I POP D BACK^APSPESLP Q
  1.  I CDOSE D
  1.  .F I=0:0 D  Q:POP!(DONE)
  1.  ..S (J,CNT)=0 F  S J=$O(^APSPRREQ(ITEM,2,J)) Q:'J  D
  1.  ...S CNT=CNT+1,DOSARY(CNT)=$P($G(^APSPRREQ(ITEM,2,J,0)),U)_U_J
  1.  ..S CNT=CNT+1,DOSARY(CNT)="<enter more>"
  1.  ..S L=0 F  S L=$O(DOSARY(L)) Q:'L  D
  1.  ...W !,L_".",?5,$P($G(DOSARY(L)),U)
  1.  ..S MAX=$O(DOSARY(999999),-1)
  1.  ..S DSEL=$$DIR^APSPUTIL("NO^1:"_MAX,"Select entry or <return> to continue",,,.POP) Q:POP
  1.  ..I 'DSEL S DONE=1 Q
  1.  ..S DIEN=$P(DOSARY(DSEL),U,2) K DOSARY
  1.  ..S DFSTAT=$$CDOSE(ITEM,DIEN,.HLFDAT,DSEL) I 'DFSTAT S POP=1 Q
  1.  ; If this is not a complex dose, only prompt for dosing instructions one time.
  1.  I POP D BACK^APSPESLP Q
  1.  E  D
  1.  .I 'DONE S SDOSRES=$$CDOSE(ITEM,,.HLFDAT)
  1.  ; stuff the sig information into the SIG multiple
  1.  I '$D(^APSPRREQ(ITEM,3,"B",$E(SIGDAT,1,30))) D
  1.  .K FDA S FDA(9009033.913,"+1,"_ITEM_",",.01)=$G(SIGDAT) D UPDATE^DIE(,"FDA") K FDA
  1.  ;W !!,"Patient Instructions: "_SIGDAT
  1.  ;S PIISIG=$$DIRYN^APSPUTIL("Include Patient Instructions in SIG","YES",,.POP) I POP D BACK^APSPESLP Q
  1.  ;I PIISIG D
  1.  ;.I $D(^APSPRREQ(ITEM,3,"B",SIGDAT)) Q
  1.  ;.K FDA S FDA(9009033.913,"+1,"_ITEM_",",.01)=$G(SIGDAT) D UPDATE^DIE(,"FDA")
  1.  S FILDAYS=$$GET1^DIQ(9009033.91,ITEM,1.5,"E")
  1.  ; display days supply
  1.  I $L(FILDAYS) W !,"Days Supply "_FILDAYS_" (no editing)"
  1.  E  D
  1.  .S DAYSSUP=$$DIR^APSPUTIL("9009033.91,1.5","Days Supply",+$G(TOTDUR),,.POP) I POP D BACK^APSPESLP Q
  1.  .I $L(DAYSSUP) S DR="1.5///^S X=$G(DAYSSUP)",DIE="^APSPRREQ(",DA=ITEM D ^DIE
  1.  S CHKQTY=$$GET1^DIQ(9009033.91,ITEM,1.4,"E")
  1.  I CHKQTY D
  1.  .W !,"Quantity "_CHKQTY_"// (no editing)"
  1.  E  D
  1.  .S DOSQTY=$$DIR^APSPUTIL("9009033.912,4","Quantity",$G(HLFDAT(9009033.91,1.4)),,.POP) Q:POP
  1.  .I DOSQTY S DR="1.4///^S X=$G(DOSQTY)",DIE="^APSPRREQ(",DA=ITEM D ^DIE
  1.  Q:POP
  1.  ; prompt for patient and provider
  1.  S DR="1.2;1.3",DA=ITEM,DIE="^APSPRREQ(" D ^DIE
  1.  ; first display sig info
  1.  W !!,"Current Sig Data:"
  1.  S I=0 F  S I=$O(^APSPRREQ(ITEM,3,I)) Q:'I  D
  1.  .W !,$G(^APSPRREQ(ITEM,3,I,0))
  1.  W ! S DONE=0
  1.  F  D  I DONE D BACK^APSPESLP Q
  1.  .S DIC="^APSPRREQ("_ITEM_",3,",DIC(0)="AEMQL",DA(1)=ITEM D ^DIC
  1.  .I Y<0,X=""!$G(DUOUT) S DONE=1 Q
  1.  .S SIGIEN=+Y
  1.  .S DIE="^APSPRREQ("_ITEM_",3,",DA(1)=ITEM,DA=SIGIEN,DR=.01 D ^DIE
  1.  D BACK^APSPESLP
  1.  Q
  1.  ;
  1.  ; INPUT - IEN  : IEN for the top level file entry
  1.  ;         DIEN : IEN of the dose instructions subfile (if applicable)
  1.  ;         ARY  : Contains all data from the HL7 message subscripted by HLFDAT(FILE #,FIELD #)
  1.  ;         SEL  ; OPTIONAL - Selection from list of current doses
  1.  ;
  1. CDOSE(IEN,DIEN,ARY,SEL) ;
  1.  N CURDOSE,DOSIEN,QT,NEWIEN,DUOUT,DIC,DEF,DEF,DEFRTE,DEFNODE
  1.  ; set up DOSIEN which will hold the subfile IEN if it exists. This allows for tracking of which entry is being edited,
  1.  ; or if a new entry is being added.
  1.  S (DOSIEN,QT)=0,DEF=""
  1.  I $G(DIEN) S DEF=$P($G(^APSPRREQ(IEN,2,DIEN,0)),U)
  1.  I '$G(DIEN),$O(^APSPRREQ(IEN,2,0)) S DEFNODE=$O(^APSPRREQ(IEN,2,0)),DEF=$P($G(^APSPRREQ(IEN,2,DEFNODE,0)),U)
  1.  S CURDOSE=$$DIR^APSPUTIL("9009033.912,.01","Dose",DEF,,.POP)
  1.  Q:POP!'$L(CURDOSE) 0
  1.  I X["@" D  Q 1
  1.  .D DIRYN^APSPUTIL("Are you sure you wish to delete this entry?","YES",,.POP)
  1.  .S FDA(9009033.912,DIEN_","_IEN_",",.01)="@" D FILE^DIE(,"FDA")
  1.  Q:POP 0
  1.  I '$D(^APSPRREQ(IEN,2,"B",CURDOSE)) D
  1.  .K FDA S FDA(9009033.912,"+1,"_IEN_",",.01)=CURDOSE D UPDATE^DIE(,"FDA","NEWIEN","ERR")
  1.  I $D(NEWIEN) S DIEN=$G(NEWIEN(1))
  1.  ; If the user has entered the @ for delete, check to see if the entry exists, delete, then quit
  1.  I $D(^APSPRREQ(IEN,2,"B",CURDOSE)) S DIEN=$O(^APSPRREQ(IEN,2,"B",CURDOSE,0))
  1.  I $D(^APSPRREQ(9009033.91,2,"B",CURDOSE)) S DOSIEN=$O(^APSPRREQ(9009033.91,2,"B",CURDOSE,0))
  1.  ; prompt for and file ROUTE
  1.  S DEFRTE=$$GET1^DIQ(9009033.912,DIEN_","_IEN_",",6,"E")
  1.  I '$L(DEFRTE) S DEFRTE=$G(ARY(9009033.912,6))
  1.  S DOSRTE=$$DIR^APSPUTIL("9009033.912,6","Route",DEFRTE,,.POP) I POP Q:0
  1.  I +DOSRTE S DR="6///^S X=+DOSRTE",DIE="^APSPRREQ("_ITEM_",2,",DA=DIEN D ^DIE
  1.  ; check to see if there is a default value for schedule (from HL7), if so, file and display, but do not allow editing
  1.  S DEFSCH=$$GET1^DIQ(9009033.912,DIEN_","_IEN_",",7,"E")
  1.  S DOSSCH=$$DIR^APSPUTIL("9009033.912,7","Schedule",DEFSCH,,.POP) I POP Q:0
  1.  I $L(DOSSCH) S DR="7///^S X=$G(DOSSCH)",DIE="^APSPRREQ("_ITEM_",2,",DA=DIEN D ^DIE
  1.  ; If the duration already exists, display it, but do not allow user to edit the value.
  1.  S FILEDUR=$$GET1^DIQ(9009033.912,DIEN_","_IEN,4,"E")
  1.  I FILEDUR]"" D
  1.  .W !,"How long "_FILEDUR_"// (no editing)"
  1.  E  D
  1.  .S DOSDUR=$$DIR^APSPUTIL("9009033.912,4","How Long",$G(HLFDAT(9009033.912,4)),,.POP) I POP Q:0
  1.  .I $L(DOSDUR) S DR="4///^S X=$G(DOSDUR)",DIE="^APSPRREQ("_ITEM_",2,",DA=DIEN D ^DIE
  1.  I POP Q 0
  1.  S DEFCON=$$GET1^DIQ(9009033.912,DIEN_","_IEN_",",5,"E")
  1.  S DOSCON=$$DIR^APSPUTIL("9009033.912,5","And/then/except",DEFCON,,.POP) I POP Q:0
  1.  I $L(DOSCON) S DR="5///^S X=$G(DOSCON)",DIE="^APSPRREQ("_ITEM_",2,",DA=DIEN D ^DIE
  1.  Q 1
  1. ORDLOC ;
  1.  N QQ
  1.  D FULL^VALM1
  1.  W !,"The default ordering location is not defined, inactive, or not properly configured."
  1.  W !,"Please check the location in your APSP CONTROL file and try again."
  1.  S QQ=$$DIR^APSPUTIL("FO","Press <return> to continue.")
  1.  Q