YSCLHLGT ;DSS-PO/HEC-hrubovcak - Get Data for HL7 message- CLOZAPINE DATA TRANSMISSION;Jul 07, 2020@10:41
;;5.01;MENTAL HEALTH;**149,175**;Dec 30, 1994;Build 7
Q
;
; Reference to ^PS(52.52 supported by IA #782
; Reference to ^PS(55 supported by IA #787
; Reference to ^PSDRUG supported by IA #221
; Reference to ^%DT supported by DBIA #10003
; Reference to ^DGPMSTAT supported by DBIA #1071
; Reference to ^DIC supported by DBIA #2051
; Reference to ^DIQ supported by DBIA #2056
; Reference to ^MPIF001 supported by DBIA #2071
; Reference to ^PSO59 supported by DBIA #4287
; Reference to ^VADPT supported by DBIA #10061
; Reference to ^XLFDT supported by DBIA #10103
;
GET(YSCLARR,DFN,PSGORD,PSORXIEN) ; Get HL7 data for transmission
; DFN patient IEN, required
; PSGORD pharmacy patient file UnitDose ien
; PSORXIEN prescription IEN
; note: PSGORD or PSORXIEN required, should be mutually exclusive
; returns YSCLARR - array of patient /site data, passed by ref.
;
N VADM ; demographics from ^VADPT call
N VAPA ; patient address info from ^VADPT call
N TMPARR ; temporary array
N ORDIEN ; IEN file #100
N OVRRDIEN ; override ien
N I,P,X,Y,TMPARND
;
; store the call parameters
S DFN=+$G(DFN),YSCLARR("*DFN")=DFN
S PSGORD=+$G(PSGORD),YSCLARR("*PSGORD")=PSGORD
S PSORXIEN=+$G(PSORXIEN),YSCLARR("*PSORXIEN")=PSORXIEN
I '(DFN>0) S YSCLARR("!ERROR!")="DFN missing" Q
I ('(PSGORD>0))&('(PSORXIEN>0)) S YSCLARR("!ERROR!")="Order or Rx IEN missing" Q
D DEM^VADPT ; patient demographics
D ADD^VADPT ; patient address
;
D FIND^DIC(603.01,,,"QX",DFN,,"C",,,"TMPARR")
;S YSCLARR("PATIENT_CLOZ REG NUM")=$G(TMPARR("DILIST",1,1))
S TMPARND=$O(TMPARR("DILIST",1,""),-1)
S YSCLARR("PATIENT_CLOZ REG NUM")=$G(TMPARR("DILIST",1,TMPARND))
;
S YSCLARR("PATIENT_NAME")=VADM(1)
S YSCLARR("PATIENT_LAST NAME")=$P(YSCLARR("PATIENT_NAME"),",",1)
S YSCLARR("PATIENT_FIRST NAME")=$P(YSCLARR("PATIENT_NAME"),",",2)
S YSCLARR("PATIENT_ICN")=$$GETICN^MPIF001(DFN) ; authoritative source, 20 chars: "nnnnnnnnnnVnnnnnn"
S YSCLARR("PATIENT_DFN")=DFN
S YSCLARR("PATIENT_DOB")=$$FMTHL7^XLFDT(+VADM(3))
S YSCLARR("PATIENT_SEX")=$P(VADM(5),U)
S YSCLARR("PATIENT_ZIP")=VAPA(6)
S YSCLARR("PATIENT_SSN")=$P(VADM(2),U)
; What should the race code be when unknown?
S P=$G(VADM(12,1))
S YSCLARR("PATIENT_RACE CODE")=$S(P:$$GET1^DIQ(10,$P(VADM(12,1),U),3),1:"2131-1")
S YSCLARR("PATIENT_RACE")=$S(P:$$GET1^DIQ(10,$P(VADM(12,1),U),.01),1:"Other Race")
;
; ethnicity code is "U" when unknown
S YSCLARR("PATIENT_ETHNICITY CODE")="U",YSCLARR("PATIENT_ETHNICITY")="UNKNOWN"
; ETHNICITY file #10.2 (field #2) ABBREVIATION [2F]
S P=$G(VADM(11,1)) D:P
. S X=$$GET1^DIQ(10.2,$P(P,U),2) Q:'("^H^N^"[(U_X_U)) ; only H or N
. S YSCLARR("PATIENT_ETHNICITY CODE")=X
. S YSCLARR("PATIENT_ETHNICITY")=$$GET1^DIQ(10.2,$P(P,U),.01)
;
D:'$D(YSCLARR("MED_DIVISION:INSTITUTION PTR")) DFLTVLUS(.YSCLARR)
D
. N DGT,DGA1,DG1,DGXFR0 ; DGPMSTAT vars
. S DGT=DT
. D EN^DGPMSTAT ; inpatient status
. S YSCLARR("PATIENT_INPAT/OUTPAT")=$S(DG1'="":"I",1:"O")
;
S YSCLARR("PATIENT_CLOZ STATUS")=$S($$GET1^DIQ(55,DFN,54,"I")="D":"DC",1:"A") ; ^DD(55,54,0)="CLOZAPINE STATUS^S^P:PRE-TREATMENT;A:ACTIVE TREATMENT;H:TREATMENT ON HOLD;D:DISCONTINUED;^SAND;2^Q"
D S YSCLARR("PROVIDER_IEN")=X
. S X=0
. S:PSORXIEN X=$$GET1^DIQ(52,PSORXIEN,4,"I")
. S:PSGORD X=$$GET1^DIQ(55.06,PSGORD_","_DFN,1,"I")
. Q:X S X=$$GET1^DIQ(55,DFN,57,"I")
;
S YSCLARR("PROVIDER_DEA")=$$GET1^DIQ(200,YSCLARR("PROVIDER_IEN"),53.2)
S YSCLARR("PROVIDER_NPI")=$$GET1^DIQ(200,YSCLARR("PROVIDER_IEN"),41.99)
S YSCLARR("PROVIDER_NAME")=$$GET1^DIQ(200,YSCLARR("PROVIDER_IEN"),.01)
S YSCLARR("PROVIDER_LAST NAME")=$P(YSCLARR("PROVIDER_NAME"),",",1)
S YSCLARR("PROVIDER_FIRST NAME")=$P(YSCLARR("PROVIDER_NAME"),",",2)
S X=$$DEFDIV(YSCLARR("PROVIDER_IEN")),YSCLARR("PROVIDER_DEFAULT DIV.")=$S(X:X,1:DUZ(2)) ; must have default division
;
N LABSTR,FREQ,FINISHDT
I +$G(PSORXIEN)>0,+$G(PSGORD)=0 S FINISHDT=$$GET1^DIQ(52,PSORXIEN,38.3,"I")
I +$G(PSGORD)>0,+$G(PSORXIEN)=0 S FINISHDT=$$GET1^DIQ(55.06,+$G(PSGORD)_","_DFN_",",19,"I")
S:'$G(FINISHDT)>0 FINISHDT=DT
S LABSTR=$$CL^YSCLHLAB(DFN,$P(FINISHDT,".")) ;YS*5.01*175-T-7 date range, ignore time
S FREQ=$P(LABSTR,U,7)
S YSCLARR("LAB_FREQ")=$S(FREQ="W":"7 Days",FREQ="B":"14 Days",FREQ="M":"28 Days",1:"")
S YSCLARR("LAB_WBC VAL")=$P(LABSTR,U,2)
S YSCLARR("LAB_COLLECTION DATE")=$S(+$P(LABSTR,U,6)>0:$$FMTHL7^XLFDT(+$P(LABSTR,U,6)),1:"")
S YSCLARR("LAB_ANC VAL")=$P(LABSTR,U,4)
;
; get drug data for inpatient
I +$G(PSGORD)>0,+$G(PSORXIEN)=0 D ; orders only
. ; CLOZAPINE MEDICATION OVERRIDES (file #53.8)
. ;ajf ; get actual ORDer file numbers from ^PS(55.06) multiple.
. N YSCLORD
. S YSCLORD=$$GET1^DIQ(55.06,PSGORD_","_DFN,66,"I")
. ; MGD - Adding MED_DOSE, MED_PRESCRIBING DATE
. S YSCLARR("MED_DOSE")=$$GET1^DIQ(55.06,PSGORD_","_DFN,301,"I") ; B3/SMH -> d 120 -> 301 to be Cloz Total Dose
. N YSCLDATE
. S YSCLDATE=$$GET1^DIQ(55.06,+$G(PSGORD)_","_DFN_",",19,"I") ; Order finished date/time
. S:'$G(YSCLDATE) YSCLDATE=$$GET1^DIQ(55.06,PSGORD_","_DFN,27,"I") ; Order Entered date/time
. S YSCLDATE=$$DATEEX(YSCLDATE)
. S YSCLARR("MED_PRESCRIBING DATE")=YSCLDATE
. ; MGD - Initial Drug entries and then get 1st entry in DISPENSE DRUG multiple
. S YSCLARR("MED_DRUG IEN")="",YSCLARR("MED_DRUG NAME")="",YSCLARR("MED_DRUG NDC")=""
. N YSCLDDIEN
. S YSCLDDIEN=0,YSCLDDIEN=$O(^PS(55,DFN,5,PSGORD,1,YSCLDDIEN))
. I YSCLDDIEN>0 D
. . S YSCLDDIEN=$P($G(^PS(55,DFN,5,PSGORD,1,YSCLDDIEN,0)),U,1)
. . S YSCLARR("MED_DRUG IEN")=YSCLDDIEN
. . S YSCLARR("MED_DRUG NAME")=$$GET1^DIQ(50,YSCLDDIEN,.01,"E")
. . S YSCLARR("MED_DRUG NDC")=$$GET1^DIQ(50,YSCLDDIEN,31,"E")
. ; MGD - Add logic to map to the Pharmacy Division
. N YSCLPDIV
. S YSCLPDIV=$$GET1^DIQ(55.06,PSGORD_","_DFN,9,"I") ; ORIGINAL WARD
. I YSCLPDIV>0 D
. . S YSCLPDIV=$$GET1^DIQ(42,YSCLPDIV,.015,"I") ; DIVISION
. . S YSCLARR("MED_PHARMACY DIVISION")=$$GET1^DIQ(42,YSCLPDIV,.015,"E")
. I YSCLPDIV>0 D
. . S YSCLPDIV=$$GET1^DIQ(40.8,YSCLPDIV,.07,"I") ; INSTITUTION FILE POINTER
. . S YSCLARR("MED_DIVISION:INSTITUTION PTR")=YSCLPDIV
. K DIC
. S OVRRDIEN=$$FIND1^DIC(53.8,"","",+YSCLORD,"A") ; IEN of file 53.8
. S YSCLARR("MED_REASON CODE")=$$GET1^DIQ(53.8,OVRRDIEN,4,"I") ; REASON FOR OVERRIDE (#4)
. S YSCLARR("MED_REASON TEXT")=$$GET1^DIQ(53.8,OVRRDIEN,4,"E")
. ; MGD - Adding RX#/ORDER#, MED_PHARMACY DIVISION
. S YSCLARR("MED_RX#/ORDER#")=$$GET1^DIQ(53.8,OVRRDIEN,1,"I")
. I YSCLARR("MED_RX#/ORDER#")="" S YSCLARR("MED_RX#/ORDER#")=$$GET1^DIQ(55.06,PSGORD_","_DFN,66,"I") ; ORDERS FILE ORDER
. S YSCLARR("MED_PHARMACY DIVISION")=$$GET1^DIQ(59.7,1,40,"I") ; DEFAULT OUTPATIENT SITE
. ;ajf ; adding approving provider
. S YSCLARR("MED_APPROVING PROVIDER")=$$GET1^DIQ(53.8,OVRRDIEN,6,"E")
. S YSCLARR("MED_APPROVING PROVIDER_LAST NAME")=$P(YSCLARR("MED_APPROVING PROVIDER"),",")
. S YSCLARR("MED_APPROVING PROVIDER_FIRST NAME")=$P(YSCLARR("MED_APPROVING PROVIDER"),",",2)
. S YSCLARR("MED_ALTERNATE REASON CODE")="",YSCLARR("MED_ALTERNATE REASON TEXT")=""
. S YSCLARR("MED_APPROVING PROVIDER IEN")=$$GET1^DIQ(53.8,OVRRDIEN,6,"I")
. S YSCLARR("MED_APPROVING PROVIDER DEA")=$$GET1^DIQ(200,YSCLARR("MED_APPROVING PROVIDER IEN"),53.2)
. Q:'(YSCLARR("MED_REASON CODE")=9) ; ^PS(53.8.9,0)="PRESCRIBER APPROVED 4 DAY SUPPLY"
. S YSCLARR("MED_ALTERNATE REASON TEXT")=$$GET1^DIQ(53.8,OVRRDIEN,5,"E")
. D RSNTXT(.YSCLARR,YSCLARR("MED_ALTERNATE REASON TEXT"))
;
; get drug data for Outpatient Prescription
I +$G(PSORXIEN)>0,+$G(PSGORD)=0 D
. K TMPARR N MAPINDX S MAPINDX=+PSORXIEN_"," ; for FileMan data map
. ; MGD - Added LOGIN DATE (#21) to list for MED_PRESCRIBING DATE
. ; MGD - Added NDC (#27) to list for MED_DRUG NDC
. D GETS^DIQ(52,PSORXIEN,".01;6;20;21;27;31;39.3;52;120;301","I","TMPARR")
. S YSCLARR("MED_RX#/ORDER#")=$G(TMPARR(52,MAPINDX,.01,"I"))
. S YSCLARR("MED_DOSE")=$G(TMPARR(52,MAPINDX,301,"I"))
. I YSCLARR("MED_DOSE")="" S YSCLARR("MED_DOSE")=$$GET1^DIQ(52.0113,"1,"_PSORXIEN_",",.01,"I")
. S YSCLARR("MED_PHARMACY DIVISION")=+$G(TMPARR(52,MAPINDX,20,"I"))
. S YSCLARR("MED_DRUG IEN")=$G(TMPARR(52,MAPINDX,6,"I"))
. S YSCLARR("MED_DRUG NAME")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),.01)
. S YSCLARR("MED_DRUG NDC")=$G(TMPARR(52,MAPINDX,27,"I"))
. ; MGD - If NDC not defined then get it from the DRUG file
. I YSCLARR("MED_DRUG NDC")="" S YSCLARR("MED_DRUG NDC")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),31,"I")
. S YSCLARR("DISPAMT")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),901,"I")
. S YSCLARR("DISPUNIT")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),902,"E")
. S YSCLARR("DISPQTY")=$$GET1^DIQ(52.0113,"1,"_PSORXIEN_",",1,"I")
. S YSCLARR("DISPQTYUNIT")="EA"
. S ORDIEN=+$G(TMPARR(52,MAPINDX,39.3,"I")) ; placer order # from prescription file
. S YSCLARR("*ORDIEN")=ORDIEN
. S YSCLARR("MED_DIVISION:INSTITUTION PTR")=$$GET1^DIQ(52,PSORXIEN,"DIVISION:RELATED INSTITUTION","I")
. N YSCLDATE
. S YSCLDATE=$G(TMPARR(52,MAPINDX,21,"I"))
. S YSCLDATE=$$DATEEX(YSCLDATE)
. S YSCLARR("MED_PRESCRIBING DATE")=YSCLDATE
. ; CLOZAPINE PRESCRIPTION OVERRIDES (file #52.52)
. N RX1STIEN,RX2NDIEN
. S RX1STIEN=+$O(^PS(52.52,"A",PSORXIEN,0)) ; 1st IEN for this Rx
. S RX2NDIEN=+$O(^PS(52.52,"A",PSORXIEN,RX1STIEN)) ; 2nd IEN for this Rx
. S YSCLARR("MED_ALTERNATE REASON CODE")="",YSCLARR("MED_ALTERNATE REASON TEXT")=""
. I $G(RX1STIEN) D
.. S YSCLARR("MED_REASON CODE")=$$GET1^DIQ(52.52,RX1STIEN,4,"I") ; pointer to file #52.54
.. S YSCLARR("MED_REASON TEXT")=$$GET1^DIQ(52.52,RX1STIEN,4,"E")
.. Q:'(YSCLARR("MED_REASON CODE")=9) ; ^PS(52.54,9,0)="PRESCRIBER APPROVED 4 DAY SUPPLY"
.. S YSCLARR("MED_ALTERNATE REASON TEXT")=$$GET1^DIQ(52.52,RX1STIEN,5,"E")
.. D RSNTXT(.YSCLARR,YSCLARR("MED_ALTERNATE REASON TEXT"))
. ; ajf ; use 2nd entry in 52.52 for approving provider
. D:$G(RX2NDIEN)
.. S YSCLARR("MED_APPROVING PROVIDER")=$$GET1^DIQ(52.52,RX2NDIEN,6,"E")
.. S YSCLARR("MED_APPROVING PROVIDER_LAST NAME")=$P(YSCLARR("MED_APPROVING PROVIDER"),",")
.. S YSCLARR("MED_APPROVING PROVIDER_FIRST NAME")=$P(YSCLARR("MED_APPROVING PROVIDER"),",",2)
.. S YSCLARR("MED_APPROVING PROVIDER IEN")=$$GET1^DIQ(52.52,RX2NDIEN,6,"I")
.. S YSCLARR("MED_APPROVING PROVIDER DEA")=$$GET1^DIQ(200,YSCLARR("MED_APPROVING PROVIDER IEN"),53.2)
;
; site /division /institution data
S X=0 D S YSCLARR("SITE_FILE #4 IEN")=X ; file # 4 pointer
. S X=YSCLARR("MED_DIVISION:INSTITUTION PTR") Q:X ; 1st choice
. S X=YSCLARR("PROVIDER_DEFAULT DIV.") Q:X ; provider's default
. S X=DUZ(2) ; must have something
;
S YSCLARR("SITE_SITE DEA")=$$GET1^DIQ(4,YSCLARR("SITE_FILE #4 IEN"),52) ;Facility DEA number
S YSCLARR("SITE_ID")=YSCLARR("SITE_FILE #4 IEN") ; site ID (division)
;
D STFLDS(.YSCLARR)
Q
;
GETCLZOR(YSCLARR,DFN,UNDSIEN) ;YSCLARR passed by ref., get clozapine order
Q:'($G(DFN))!'$G(UNDSIEN) ; required
N DRUGIEN,I,YSFMROOT,YSIENS,YSFMERR
K YSCLARR D DFLTVLUS(.YSCLARR)
S YSCLARR("*55.07IEN",UNDSIEN)=""
S YSIENS=UNDSIEN_","_DFN_","
D LIST^DIC(55.07,","_YSIENS,".01:.01;.01:31;.02","IE",,,,,,,"YSFMROOT","YSFMERR") ; get a list of the drugs
S I=0 F S I=$O(YSFMROOT("DILIST",1,I)) Q:'I D
. S DRUGIEN=+$G(YSFMROOT("DILIST",1,I)) Q:'$D(^PSDRUG("ACLOZ",DRUGIEN)) ; not Clozapine
. S YSCLARR("*RPT",I,"MED_DRUG IEN")=DRUGIEN
. S YSCLARR("*RPT",I,"MED_DRUG NAME")=YSFMROOT("DILIST","ID",I,"C1",1)
. S YSCLARR("*RPT",I,"MED_DRUG NDC")=YSFMROOT("DILIST","ID",I,"C2",1)
. S YSCLARR("*RPT",I,"DISPAMT")=$$GET1^DIQ(50,YSCLARR("*RPT",I,"MED_DRUG IEN"),901,"I")
. S YSCLARR("*RPT",I,"DISPUNIT")=$$GET1^DIQ(50,YSCLARR("*RPT",I,"MED_DRUG IEN"),902,"E")
. S YSCLARR("*RPT",I,"DISPQTY")=YSFMROOT("DILIST","ID",I,.02)
. S YSCLARR("*RPT",I,"DISPQTYUNIT")="EA"
;
Q:'$D(YSCLARR("*RPT")) ; no clozapine drug found
K YSFMERR,YSFMROOT
; MGD - Added #66 to returned fields
D GETS^DIQ(55.06,YSIENS,".01;27;28;66;301","IE","YSFMROOT","YSFMERR")
; I YSFMROOT(55.06,YSIENS,28,"I")="A" then order is active
S YSCLARR("MED_DOSE")=$G(YSFMROOT(55.06,YSIENS,301,"E"))
S YSCLARR("MED_STATUS")=$G(YSFMROOT(55.06,YSIENS,28,"E"))
S YSCLARR("MED_RX#/ORDER#")=$G(YSFMROOT(55.06,YSIENS,66,"E")) ; MGD - Changed .01 to 66
N YSCLDATE
S YSCLDATE=+$G(YSFMROOT(55.06,YSIENS,27,"I"))
S YSCLDATE=$$DATEEX(YSCLDATE)
S YSCLARR("MED_PRESCRIBING DATE")=YSCLDATE
; use default division for Orders, may need to change
S YSCLARR("MED_PHARMACY DIVISION")=$$GET1^DIQ(59.7,1,40,"I") ; DEFAULT OUTPATIENT SITE
Q
;
DEFDIV(USRIEN) ; function, return default division IEN for a user
Q:'$G(USRIEN)
; ^VA(200,D0,2,D1,0)= (#.01) DIVISION [1P:4] ^ (#1) DEFAULT [2S] ^
N J,RSLT,YSFMERR,YSFMLST
S RSLT=+$G(^TMP($J,"YS user dflt div",USRIEN))
I RSLT Q RSLT ; already found
D LIST^DIC(200.02,","_USRIEN_",",".01;1","I",,,,,,,"YSFMLST","YSFMERR") ; list of the divisions
; go through list find default
S RSLT=0 S J=0 F S J=$O(YSFMLST("DILIST","ID",J)) Q:'J!RSLT D
. I YSFMLST("DILIST","ID",J,1) S RSLT=YSFMLST("DILIST","ID",J,.01) ; if default save IEN
;
S:RSLT ^TMP($J,"YS user dflt div",USRIEN)=RSLT
Q RSLT
;
NCPDPF59(YS59IEN) ; return NCPDP from OUTPATIENT SITE file (#59)
S YS59IEN=+$G(YS59IEN) ; prevent null subscript
D:'$D(^TMP($J,"YS FILE#59",YS59IEN)) PSS^PSO59(YS59IEN,,"YS FILE#59")
Q $G(^TMP($J,"YS FILE#59",YS59IEN,1008))
;
RSNTXT(YSCLARR,RSNTXT) ; e.g. "Weather Related Conditions: some free text"
N Y S Y=$P(RSNTXT,":"),YSCLARR("MED_ALTERNATE REASON TEXT")=Y
S YSCLARR("MED_ALTERNATE REASON CODE")=$S(Y="Weather Related Conditions":1,Y="Mail Order Delay":2,Y="Inpatient Going On Leave":3,Y="IP Order Override with Outside Lab Results":4,1:"")
Q
STFLDS(YSCLARR) ; passed by ref.
N X,Y,YSITE
S YSITE=+$G(YSCLARR("SITE_FILE #4 IEN")) D STINFO(YSITE)
S YSCLARR("SITE_SITE NAME")=$G(^TMP($J,"YS file#4",YSITE,.01))
S YSCLARR("SITE_STATE")=$G(^TMP($J,"YS file#4",YSITE,.02))
S YSCLARR("SITE_STREET ADDR 1")=$G(^TMP($J,"YS file#4",YSITE,1.01))
S YSCLARR("SITE_STREET ADDR 2")=$G(^TMP($J,"YS file#4",YSITE,1.02))
S YSCLARR("SITE_CITY")=$G(^TMP($J,"YS file#4",YSITE,1.03))
S YSCLARR("SITE_ZIP")=$G(^TMP($J,"YS file#4",YSITE,1.04))
S YSCLARR("SITE_ID")=YSITE ; site ID (division)
S YSCLARR("SITE_STATION")=$E($G(^TMP($J,"YS file#4",YSITE,99)),1,3)
; one time lookups per site
D S YSCLARR("SITE_DEFAULT OUTPATIENT SITE")=X
. S X=+$G(^TMP($J,"YS deflt outpt site")) Q:X
. S X=$$GET1^DIQ(59.7,1,40,"I") ; file #59 pointer
. S ^TMP($J,"YS deflt outpt site")=X ; one time lookup
;
D S YSCLARR("SITE_DEFAULT OUTPATIENT SITE")=X
. S X=+$G(^TMP($J,"YS site dea#")) Q:X
. S X=$$GET1^DIQ(4,YSITE,52) ;Facility DEA number
. S ^TMP($J,"YS site dea#")=X
;
D S YSCLARR("SITE_PHARMACY NCPDP")=X
. N YSDIV S YSDIV=+$G(YSCLARR("MED_PHARMACY DIVISION"))
. ;ajf removed +$G to allow leading zeros for NCPDP
. S X=$G(^TMP($J,"YS pharmacy ncpdp",YSDIV)) Q:X
. S X=$$NCPDPF59(YSDIV)
. S ^TMP($J,"YS pharmacy ncpdp",YSDIV)=X
Q
;
STINFO(YSFL4IEN) ; institution lookup
Q:$D(^TMP($J,"YS file#4",YSFL4IEN)) ; already got it
N YSFLD F YSFLD=.01,.02,1.01,1.02,1.03,1.04,99 S ^TMP($J,"YS file#4",YSFL4IEN,YSFLD)=$$GET1^DIQ(4,YSFL4IEN,YSFLD)
Q
;
DFLTVLUS(YSCLARR) ;
; default values for inpatient and outpatient
S YSCLARR("DISPAMT")=""
S YSCLARR("DISPUNITS")=""
S YSCLARR("DISPQTY")=""
S YSCLARR("DISPQTYUNIT")=""
S YSCLARR("MED_REASON CODE")=""
S YSCLARR("MED_REASON TEXT")=""
S YSCLARR("MED_ALTERNATE REASON CODE")=""
S YSCLARR("MED_ALTERNATE REASON TEXT")=""
S YSCLARR("MED_DOSE")=""
S YSCLARR("MED_STATUS")=""
S YSCLARR("MED_RX#/ORDER#")=""
S YSCLARR("MED_PRESCRIBING DATE")=""
;ajf ; Add Approving provider
S YSCLARR("MED_APPROVING PROVIDER")=""
S YSCLARR("MED_APPROVING PROVIDER_LAST NAME")=""
S YSCLARR("MED_APPROVING PROVIDER_FIRST NAME")=""
S YSCLARR("MED_APPROVING PROVIDER DEA")=""
S YSCLARR("MED_APPROVING PROVIDER IEN")=""
; INSTITUTION file (#4) values
S YSCLARR("MED_DIVISION:INSTITUTION PTR")=""
S YSCLARR("SITE_FILE #4 IEN")=""
Q
;
DATEEX(YSCLDATE) ; Convert FileMan date to YYYYMMDD format
N Y,YSCLMMDD
S Y=YSCLDATE
S Y=$P(YSCLDATE,".",1)
I Y'?7N Q ""
S YSCLMMDD=$E(YSCLDATE,4,7)
D DD^%DT
S YSCLDATE=$E($P(Y,",",2),2,5)
S YSCLDATE=YSCLDATE_YSCLMMDD
Q YSCLDATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSCLHLGT 16598 printed Sep 23, 2025@19:49:46 Page 2
YSCLHLGT ;DSS-PO/HEC-hrubovcak - Get Data for HL7 message- CLOZAPINE DATA TRANSMISSION;Jul 07, 2020@10:41
+1 ;;5.01;MENTAL HEALTH;**149,175**;Dec 30, 1994;Build 7
+2 QUIT
+3 ;
+4 ; Reference to ^PS(52.52 supported by IA #782
+5 ; Reference to ^PS(55 supported by IA #787
+6 ; Reference to ^PSDRUG supported by IA #221
+7 ; Reference to ^%DT supported by DBIA #10003
+8 ; Reference to ^DGPMSTAT supported by DBIA #1071
+9 ; Reference to ^DIC supported by DBIA #2051
+10 ; Reference to ^DIQ supported by DBIA #2056
+11 ; Reference to ^MPIF001 supported by DBIA #2071
+12 ; Reference to ^PSO59 supported by DBIA #4287
+13 ; Reference to ^VADPT supported by DBIA #10061
+14 ; Reference to ^XLFDT supported by DBIA #10103
+15 ;
GET(YSCLARR,DFN,PSGORD,PSORXIEN) ; Get HL7 data for transmission
+1 ; DFN patient IEN, required
+2 ; PSGORD pharmacy patient file UnitDose ien
+3 ; PSORXIEN prescription IEN
+4 ; note: PSGORD or PSORXIEN required, should be mutually exclusive
+5 ; returns YSCLARR - array of patient /site data, passed by ref.
+6 ;
+7 ; demographics from ^VADPT call
NEW VADM
+8 ; patient address info from ^VADPT call
NEW VAPA
+9 ; temporary array
NEW TMPARR
+10 ; IEN file #100
NEW ORDIEN
+11 ; override ien
NEW OVRRDIEN
+12 NEW I,P,X,Y,TMPARND
+13 ;
+14 ; store the call parameters
+15 SET DFN=+$GET(DFN)
SET YSCLARR("*DFN")=DFN
+16 SET PSGORD=+$GET(PSGORD)
SET YSCLARR("*PSGORD")=PSGORD
+17 SET PSORXIEN=+$GET(PSORXIEN)
SET YSCLARR("*PSORXIEN")=PSORXIEN
+18 IF '(DFN>0)
SET YSCLARR("!ERROR!")="DFN missing"
QUIT
+19 IF ('(PSGORD>0))&('(PSORXIEN>0))
SET YSCLARR("!ERROR!")="Order or Rx IEN missing"
QUIT
+20 ; patient demographics
DO DEM^VADPT
+21 ; patient address
DO ADD^VADPT
+22 ;
+23 DO FIND^DIC(603.01,,,"QX",DFN,,"C",,,"TMPARR")
+24 ;S YSCLARR("PATIENT_CLOZ REG NUM")=$G(TMPARR("DILIST",1,1))
+25 SET TMPARND=$ORDER(TMPARR("DILIST",1,""),-1)
+26 SET YSCLARR("PATIENT_CLOZ REG NUM")=$GET(TMPARR("DILIST",1,TMPARND))
+27 ;
+28 SET YSCLARR("PATIENT_NAME")=VADM(1)
+29 SET YSCLARR("PATIENT_LAST NAME")=$PIECE(YSCLARR("PATIENT_NAME"),",",1)
+30 SET YSCLARR("PATIENT_FIRST NAME")=$PIECE(YSCLARR("PATIENT_NAME"),",",2)
+31 ; authoritative source, 20 chars: "nnnnnnnnnnVnnnnnn"
SET YSCLARR("PATIENT_ICN")=$$GETICN^MPIF001(DFN)
+32 SET YSCLARR("PATIENT_DFN")=DFN
+33 SET YSCLARR("PATIENT_DOB")=$$FMTHL7^XLFDT(+VADM(3))
+34 SET YSCLARR("PATIENT_SEX")=$PIECE(VADM(5),U)
+35 SET YSCLARR("PATIENT_ZIP")=VAPA(6)
+36 SET YSCLARR("PATIENT_SSN")=$PIECE(VADM(2),U)
+37 ; What should the race code be when unknown?
+38 SET P=$GET(VADM(12,1))
+39 SET YSCLARR("PATIENT_RACE CODE")=$SELECT(P:$$GET1^DIQ(10,$PIECE(VADM(12,1),U),3),1:"2131-1")
+40 SET YSCLARR("PATIENT_RACE")=$SELECT(P:$$GET1^DIQ(10,$PIECE(VADM(12,1),U),.01),1:"Other Race")
+41 ;
+42 ; ethnicity code is "U" when unknown
+43 SET YSCLARR("PATIENT_ETHNICITY CODE")="U"
SET YSCLARR("PATIENT_ETHNICITY")="UNKNOWN"
+44 ; ETHNICITY file #10.2 (field #2) ABBREVIATION [2F]
+45 SET P=$GET(VADM(11,1))
if P
Begin DoDot:1
+46 ; only H or N
SET X=$$GET1^DIQ(10.2,$PIECE(P,U),2)
if '("^H^N^"[(U_X_U))
QUIT
+47 SET YSCLARR("PATIENT_ETHNICITY CODE")=X
+48 SET YSCLARR("PATIENT_ETHNICITY")=$$GET1^DIQ(10.2,$PIECE(P,U),.01)
End DoDot:1
+49 ;
+50 if '$DATA(YSCLARR("MED_DIVISION
DO DFLTVLUS(.YSCLARR)
+51 Begin DoDot:1
+52 ; DGPMSTAT vars
NEW DGT,DGA1,DG1,DGXFR0
+53 SET DGT=DT
+54 ; inpatient status
DO EN^DGPMSTAT
+55 SET YSCLARR("PATIENT_INPAT/OUTPAT")=$SELECT(DG1'="":"I",1:"O")
End DoDot:1
+56 ;
+57 ; ^DD(55,54,0)="CLOZAPINE STATUS^S^P:PRE-TREATMENT;A:ACTIVE TREATMENT;H:TREATMENT ON HOLD;D:DISCONTINUED;^SAND;2^Q"
SET YSCLARR("PATIENT_CLOZ STATUS")=$SELECT($$GET1^DIQ(55,DFN,54,"I")="D":"DC",1:"A")
+58 Begin DoDot:1
+59 SET X=0
+60 if PSORXIEN
SET X=$$GET1^DIQ(52,PSORXIEN,4,"I")
+61 if PSGORD
SET X=$$GET1^DIQ(55.06,PSGORD_","_DFN,1,"I")
+62 if X
QUIT
SET X=$$GET1^DIQ(55,DFN,57,"I")
End DoDot:1
SET YSCLARR("PROVIDER_IEN")=X
+63 ;
+64 SET YSCLARR("PROVIDER_DEA")=$$GET1^DIQ(200,YSCLARR("PROVIDER_IEN"),53.2)
+65 SET YSCLARR("PROVIDER_NPI")=$$GET1^DIQ(200,YSCLARR("PROVIDER_IEN"),41.99)
+66 SET YSCLARR("PROVIDER_NAME")=$$GET1^DIQ(200,YSCLARR("PROVIDER_IEN"),.01)
+67 SET YSCLARR("PROVIDER_LAST NAME")=$PIECE(YSCLARR("PROVIDER_NAME"),",",1)
+68 SET YSCLARR("PROVIDER_FIRST NAME")=$PIECE(YSCLARR("PROVIDER_NAME"),",",2)
+69 ; must have default division
SET X=$$DEFDIV(YSCLARR("PROVIDER_IEN"))
SET YSCLARR("PROVIDER_DEFAULT DIV.")=$SELECT(X:X,1:DUZ(2))
+70 ;
+71 NEW LABSTR,FREQ,FINISHDT
+72 IF +$GET(PSORXIEN)>0
IF +$GET(PSGORD)=0
SET FINISHDT=$$GET1^DIQ(52,PSORXIEN,38.3,"I")
+73 IF +$GET(PSGORD)>0
IF +$GET(PSORXIEN)=0
SET FINISHDT=$$GET1^DIQ(55.06,+$GET(PSGORD)_","_DFN_",",19,"I")
+74 if '$GET(FINISHDT)>0
SET FINISHDT=DT
+75 ;YS*5.01*175-T-7 date range, ignore time
SET LABSTR=$$CL^YSCLHLAB(DFN,$PIECE(FINISHDT,"."))
+76 SET FREQ=$PIECE(LABSTR,U,7)
+77 SET YSCLARR("LAB_FREQ")=$SELECT(FREQ="W":"7 Days",FREQ="B":"14 Days",FREQ="M":"28 Days",1:"")
+78 SET YSCLARR("LAB_WBC VAL")=$PIECE(LABSTR,U,2)
+79 SET YSCLARR("LAB_COLLECTION DATE")=$SELECT(+$PIECE(LABSTR,U,6)>0:$$FMTHL7^XLFDT(+$PIECE(LABSTR,U,6)),1:"")
+80 SET YSCLARR("LAB_ANC VAL")=$PIECE(LABSTR,U,4)
+81 ;
+82 ; get drug data for inpatient
+83 ; orders only
IF +$GET(PSGORD)>0
IF +$GET(PSORXIEN)=0
Begin DoDot:1
+84 ; CLOZAPINE MEDICATION OVERRIDES (file #53.8)
+85 ;ajf ; get actual ORDer file numbers from ^PS(55.06) multiple.
+86 NEW YSCLORD
+87 SET YSCLORD=$$GET1^DIQ(55.06,PSGORD_","_DFN,66,"I")
+88 ; MGD - Adding MED_DOSE, MED_PRESCRIBING DATE
+89 ; B3/SMH -> d 120 -> 301 to be Cloz Total Dose
SET YSCLARR("MED_DOSE")=$$GET1^DIQ(55.06,PSGORD_","_DFN,301,"I")
+90 NEW YSCLDATE
+91 ; Order finished date/time
SET YSCLDATE=$$GET1^DIQ(55.06,+$GET(PSGORD)_","_DFN_",",19,"I")
+92 ; Order Entered date/time
if '$GET(YSCLDATE)
SET YSCLDATE=$$GET1^DIQ(55.06,PSGORD_","_DFN,27,"I")
+93 SET YSCLDATE=$$DATEEX(YSCLDATE)
+94 SET YSCLARR("MED_PRESCRIBING DATE")=YSCLDATE
+95 ; MGD - Initial Drug entries and then get 1st entry in DISPENSE DRUG multiple
+96 SET YSCLARR("MED_DRUG IEN")=""
SET YSCLARR("MED_DRUG NAME")=""
SET YSCLARR("MED_DRUG NDC")=""
+97 NEW YSCLDDIEN
+98 SET YSCLDDIEN=0
SET YSCLDDIEN=$ORDER(^PS(55,DFN,5,PSGORD,1,YSCLDDIEN))
+99 IF YSCLDDIEN>0
Begin DoDot:2
+100 SET YSCLDDIEN=$PIECE($GET(^PS(55,DFN,5,PSGORD,1,YSCLDDIEN,0)),U,1)
+101 SET YSCLARR("MED_DRUG IEN")=YSCLDDIEN
+102 SET YSCLARR("MED_DRUG NAME")=$$GET1^DIQ(50,YSCLDDIEN,.01,"E")
+103 SET YSCLARR("MED_DRUG NDC")=$$GET1^DIQ(50,YSCLDDIEN,31,"E")
End DoDot:2
+104 ; MGD - Add logic to map to the Pharmacy Division
+105 NEW YSCLPDIV
+106 ; ORIGINAL WARD
SET YSCLPDIV=$$GET1^DIQ(55.06,PSGORD_","_DFN,9,"I")
+107 IF YSCLPDIV>0
Begin DoDot:2
+108 ; DIVISION
SET YSCLPDIV=$$GET1^DIQ(42,YSCLPDIV,.015,"I")
+109 SET YSCLARR("MED_PHARMACY DIVISION")=$$GET1^DIQ(42,YSCLPDIV,.015,"E")
End DoDot:2
+110 IF YSCLPDIV>0
Begin DoDot:2
+111 ; INSTITUTION FILE POINTER
SET YSCLPDIV=$$GET1^DIQ(40.8,YSCLPDIV,.07,"I")
+112 SET YSCLARR("MED_DIVISION:INSTITUTION PTR")=YSCLPDIV
End DoDot:2
+113 KILL DIC
+114 ; IEN of file 53.8
SET OVRRDIEN=$$FIND1^DIC(53.8,"","",+YSCLORD,"A")
+115 ; REASON FOR OVERRIDE (#4)
SET YSCLARR("MED_REASON CODE")=$$GET1^DIQ(53.8,OVRRDIEN,4,"I")
+116 SET YSCLARR("MED_REASON TEXT")=$$GET1^DIQ(53.8,OVRRDIEN,4,"E")
+117 ; MGD - Adding RX#/ORDER#, MED_PHARMACY DIVISION
+118 SET YSCLARR("MED_RX#/ORDER#")=$$GET1^DIQ(53.8,OVRRDIEN,1,"I")
+119 ; ORDERS FILE ORDER
IF YSCLARR("MED_RX#/ORDER#")=""
SET YSCLARR("MED_RX#/ORDER#")=$$GET1^DIQ(55.06,PSGORD_","_DFN,66,"I")
+120 ; DEFAULT OUTPATIENT SITE
SET YSCLARR("MED_PHARMACY DIVISION")=$$GET1^DIQ(59.7,1,40,"I")
+121 ;ajf ; adding approving provider
+122 SET YSCLARR("MED_APPROVING PROVIDER")=$$GET1^DIQ(53.8,OVRRDIEN,6,"E")
+123 SET YSCLARR("MED_APPROVING PROVIDER_LAST NAME")=$PIECE(YSCLARR("MED_APPROVING PROVIDER"),",")
+124 SET YSCLARR("MED_APPROVING PROVIDER_FIRST NAME")=$PIECE(YSCLARR("MED_APPROVING PROVIDER"),",",2)
+125 SET YSCLARR("MED_ALTERNATE REASON CODE")=""
SET YSCLARR("MED_ALTERNATE REASON TEXT")=""
+126 SET YSCLARR("MED_APPROVING PROVIDER IEN")=$$GET1^DIQ(53.8,OVRRDIEN,6,"I")
+127 SET YSCLARR("MED_APPROVING PROVIDER DEA")=$$GET1^DIQ(200,YSCLARR("MED_APPROVING PROVIDER IEN"),53.2)
+128 ; ^PS(53.8.9,0)="PRESCRIBER APPROVED 4 DAY SUPPLY"
if '(YSCLARR("MED_REASON CODE")=9)
QUIT
+129 SET YSCLARR("MED_ALTERNATE REASON TEXT")=$$GET1^DIQ(53.8,OVRRDIEN,5,"E")
+130 DO RSNTXT(.YSCLARR,YSCLARR("MED_ALTERNATE REASON TEXT"))
End DoDot:1
+131 ;
+132 ; get drug data for Outpatient Prescription
+133 IF +$GET(PSORXIEN)>0
IF +$GET(PSGORD)=0
Begin DoDot:1
+134 ; for FileMan data map
KILL TMPARR
NEW MAPINDX
SET MAPINDX=+PSORXIEN_","
+135 ; MGD - Added LOGIN DATE (#21) to list for MED_PRESCRIBING DATE
+136 ; MGD - Added NDC (#27) to list for MED_DRUG NDC
+137 DO GETS^DIQ(52,PSORXIEN,".01;6;20;21;27;31;39.3;52;120;301","I","TMPARR")
+138 SET YSCLARR("MED_RX#/ORDER#")=$GET(TMPARR(52,MAPINDX,.01,"I"))
+139 SET YSCLARR("MED_DOSE")=$GET(TMPARR(52,MAPINDX,301,"I"))
+140 IF YSCLARR("MED_DOSE")=""
SET YSCLARR("MED_DOSE")=$$GET1^DIQ(52.0113,"1,"_PSORXIEN_",",.01,"I")
+141 SET YSCLARR("MED_PHARMACY DIVISION")=+$GET(TMPARR(52,MAPINDX,20,"I"))
+142 SET YSCLARR("MED_DRUG IEN")=$GET(TMPARR(52,MAPINDX,6,"I"))
+143 SET YSCLARR("MED_DRUG NAME")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),.01)
+144 SET YSCLARR("MED_DRUG NDC")=$GET(TMPARR(52,MAPINDX,27,"I"))
+145 ; MGD - If NDC not defined then get it from the DRUG file
+146 IF YSCLARR("MED_DRUG NDC")=""
SET YSCLARR("MED_DRUG NDC")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),31,"I")
+147 SET YSCLARR("DISPAMT")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),901,"I")
+148 SET YSCLARR("DISPUNIT")=$$GET1^DIQ(50,+YSCLARR("MED_DRUG IEN"),902,"E")
+149 SET YSCLARR("DISPQTY")=$$GET1^DIQ(52.0113,"1,"_PSORXIEN_",",1,"I")
+150 SET YSCLARR("DISPQTYUNIT")="EA"
+151 ; placer order # from prescription file
SET ORDIEN=+$GET(TMPARR(52,MAPINDX,39.3,"I"))
+152 SET YSCLARR("*ORDIEN")=ORDIEN
+153 SET YSCLARR("MED_DIVISION:INSTITUTION PTR")=$$GET1^DIQ(52,PSORXIEN,"DIVISION:RELATED INSTITUTION","I")
+154 NEW YSCLDATE
+155 SET YSCLDATE=$GET(TMPARR(52,MAPINDX,21,"I"))
+156 SET YSCLDATE=$$DATEEX(YSCLDATE)
+157 SET YSCLARR("MED_PRESCRIBING DATE")=YSCLDATE
+158 ; CLOZAPINE PRESCRIPTION OVERRIDES (file #52.52)
+159 NEW RX1STIEN,RX2NDIEN
+160 ; 1st IEN for this Rx
SET RX1STIEN=+$ORDER(^PS(52.52,"A",PSORXIEN,0))
+161 ; 2nd IEN for this Rx
SET RX2NDIEN=+$ORDER(^PS(52.52,"A",PSORXIEN,RX1STIEN))
+162 SET YSCLARR("MED_ALTERNATE REASON CODE")=""
SET YSCLARR("MED_ALTERNATE REASON TEXT")=""
+163 IF $GET(RX1STIEN)
Begin DoDot:2
+164 ; pointer to file #52.54
SET YSCLARR("MED_REASON CODE")=$$GET1^DIQ(52.52,RX1STIEN,4,"I")
+165 SET YSCLARR("MED_REASON TEXT")=$$GET1^DIQ(52.52,RX1STIEN,4,"E")
+166 ; ^PS(52.54,9,0)="PRESCRIBER APPROVED 4 DAY SUPPLY"
if '(YSCLARR("MED_REASON CODE")=9)
QUIT
+167 SET YSCLARR("MED_ALTERNATE REASON TEXT")=$$GET1^DIQ(52.52,RX1STIEN,5,"E")
+168 DO RSNTXT(.YSCLARR,YSCLARR("MED_ALTERNATE REASON TEXT"))
End DoDot:2
+169 ; ajf ; use 2nd entry in 52.52 for approving provider
+170 if $GET(RX2NDIEN)
Begin DoDot:2
+171 SET YSCLARR("MED_APPROVING PROVIDER")=$$GET1^DIQ(52.52,RX2NDIEN,6,"E")
+172 SET YSCLARR("MED_APPROVING PROVIDER_LAST NAME")=$PIECE(YSCLARR("MED_APPROVING PROVIDER"),",")
+173 SET YSCLARR("MED_APPROVING PROVIDER_FIRST NAME")=$PIECE(YSCLARR("MED_APPROVING PROVIDER"),",",2)
+174 SET YSCLARR("MED_APPROVING PROVIDER IEN")=$$GET1^DIQ(52.52,RX2NDIEN,6,"I")
+175 SET YSCLARR("MED_APPROVING PROVIDER DEA")=$$GET1^DIQ(200,YSCLARR("MED_APPROVING PROVIDER IEN"),53.2)
End DoDot:2
End DoDot:1
+176 ;
+177 ; site /division /institution data
+178 ; file # 4 pointer
SET X=0
Begin DoDot:1
+179 ; 1st choice
SET X=YSCLARR("MED_DIVISION:INSTITUTION PTR")
if X
QUIT
+180 ; provider's default
SET X=YSCLARR("PROVIDER_DEFAULT DIV.")
if X
QUIT
+181 ; must have something
SET X=DUZ(2)
End DoDot:1
SET YSCLARR("SITE_FILE #4 IEN")=X
+182 ;
+183 ;Facility DEA number
SET YSCLARR("SITE_SITE DEA")=$$GET1^DIQ(4,YSCLARR("SITE_FILE #4 IEN"),52)
+184 ; site ID (division)
SET YSCLARR("SITE_ID")=YSCLARR("SITE_FILE #4 IEN")
+185 ;
+186 DO STFLDS(.YSCLARR)
+187 QUIT
+188 ;
GETCLZOR(YSCLARR,DFN,UNDSIEN) ;YSCLARR passed by ref., get clozapine order
+1 ; required
if '($GET(DFN))!'$GET(UNDSIEN)
QUIT
+2 NEW DRUGIEN,I,YSFMROOT,YSIENS,YSFMERR
+3 KILL YSCLARR
DO DFLTVLUS(.YSCLARR)
+4 SET YSCLARR("*55.07IEN",UNDSIEN)=""
+5 SET YSIENS=UNDSIEN_","_DFN_","
+6 ; get a list of the drugs
DO LIST^DIC(55.07,","_YSIENS,".01:.01;.01:31;.02","IE",,,,,,,"YSFMROOT","YSFMERR")
+7 SET I=0
FOR
SET I=$ORDER(YSFMROOT("DILIST",1,I))
if 'I
QUIT
Begin DoDot:1
+8 ; not Clozapine
SET DRUGIEN=+$GET(YSFMROOT("DILIST",1,I))
if '$DATA(^PSDRUG("ACLOZ",DRUGIEN))
QUIT
+9 SET YSCLARR("*RPT",I,"MED_DRUG IEN")=DRUGIEN
+10 SET YSCLARR("*RPT",I,"MED_DRUG NAME")=YSFMROOT("DILIST","ID",I,"C1",1)
+11 SET YSCLARR("*RPT",I,"MED_DRUG NDC")=YSFMROOT("DILIST","ID",I,"C2",1)
+12 SET YSCLARR("*RPT",I,"DISPAMT")=$$GET1^DIQ(50,YSCLARR("*RPT",I,"MED_DRUG IEN"),901,"I")
+13 SET YSCLARR("*RPT",I,"DISPUNIT")=$$GET1^DIQ(50,YSCLARR("*RPT",I,"MED_DRUG IEN"),902,"E")
+14 SET YSCLARR("*RPT",I,"DISPQTY")=YSFMROOT("DILIST","ID",I,.02)
+15 SET YSCLARR("*RPT",I,"DISPQTYUNIT")="EA"
End DoDot:1
+16 ;
+17 ; no clozapine drug found
if '$DATA(YSCLARR("*RPT"))
QUIT
+18 KILL YSFMERR,YSFMROOT
+19 ; MGD - Added #66 to returned fields
+20 DO GETS^DIQ(55.06,YSIENS,".01;27;28;66;301","IE","YSFMROOT","YSFMERR")
+21 ; I YSFMROOT(55.06,YSIENS,28,"I")="A" then order is active
+22 SET YSCLARR("MED_DOSE")=$GET(YSFMROOT(55.06,YSIENS,301,"E"))
+23 SET YSCLARR("MED_STATUS")=$GET(YSFMROOT(55.06,YSIENS,28,"E"))
+24 ; MGD - Changed .01 to 66
SET YSCLARR("MED_RX#/ORDER#")=$GET(YSFMROOT(55.06,YSIENS,66,"E"))
+25 NEW YSCLDATE
+26 SET YSCLDATE=+$GET(YSFMROOT(55.06,YSIENS,27,"I"))
+27 SET YSCLDATE=$$DATEEX(YSCLDATE)
+28 SET YSCLARR("MED_PRESCRIBING DATE")=YSCLDATE
+29 ; use default division for Orders, may need to change
+30 ; DEFAULT OUTPATIENT SITE
SET YSCLARR("MED_PHARMACY DIVISION")=$$GET1^DIQ(59.7,1,40,"I")
+31 QUIT
+32 ;
DEFDIV(USRIEN) ; function, return default division IEN for a user
+1 if '$GET(USRIEN)
QUIT
+2 ; ^VA(200,D0,2,D1,0)= (#.01) DIVISION [1P:4] ^ (#1) DEFAULT [2S] ^
+3 NEW J,RSLT,YSFMERR,YSFMLST
+4 SET RSLT=+$GET(^TMP($JOB,"YS user dflt div",USRIEN))
+5 ; already found
IF RSLT
QUIT RSLT
+6 ; list of the divisions
DO LIST^DIC(200.02,","_USRIEN_",",".01;1","I",,,,,,,"YSFMLST","YSFMERR")
+7 ; go through list find default
+8 SET RSLT=0
SET J=0
FOR
SET J=$ORDER(YSFMLST("DILIST","ID",J))
if 'J!RSLT
QUIT
Begin DoDot:1
+9 ; if default save IEN
IF YSFMLST("DILIST","ID",J,1)
SET RSLT=YSFMLST("DILIST","ID",J,.01)
End DoDot:1
+10 ;
+11 if RSLT
SET ^TMP($JOB,"YS user dflt div",USRIEN)=RSLT
+12 QUIT RSLT
+13 ;
NCPDPF59(YS59IEN) ; return NCPDP from OUTPATIENT SITE file (#59)
+1 ; prevent null subscript
SET YS59IEN=+$GET(YS59IEN)
+2 if '$DATA(^TMP($JOB,"YS FILE#59",YS59IEN))
DO PSS^PSO59(YS59IEN,,"YS FILE#59")
+3 QUIT $GET(^TMP($JOB,"YS FILE#59",YS59IEN,1008))
+4 ;
RSNTXT(YSCLARR,RSNTXT) ; e.g. "Weather Related Conditions: some free text"
+1 NEW Y
SET Y=$PIECE(RSNTXT,":")
SET YSCLARR("MED_ALTERNATE REASON TEXT")=Y
+2 SET YSCLARR("MED_ALTERNATE REASON CODE")=$SELECT(Y="Weather Related Conditions":1,Y="Mail Order Delay":2,Y="Inpatient Going On Leave":3,Y="IP Order Override with Outside Lab Results":4,1:"")
+3 QUIT
STFLDS(YSCLARR) ; passed by ref.
+1 NEW X,Y,YSITE
+2 SET YSITE=+$GET(YSCLARR("SITE_FILE #4 IEN"))
DO STINFO(YSITE)
+3 SET YSCLARR("SITE_SITE NAME")=$GET(^TMP($JOB,"YS file#4",YSITE,.01))
+4 SET YSCLARR("SITE_STATE")=$GET(^TMP($JOB,"YS file#4",YSITE,.02))
+5 SET YSCLARR("SITE_STREET ADDR 1")=$GET(^TMP($JOB,"YS file#4",YSITE,1.01))
+6 SET YSCLARR("SITE_STREET ADDR 2")=$GET(^TMP($JOB,"YS file#4",YSITE,1.02))
+7 SET YSCLARR("SITE_CITY")=$GET(^TMP($JOB,"YS file#4",YSITE,1.03))
+8 SET YSCLARR("SITE_ZIP")=$GET(^TMP($JOB,"YS file#4",YSITE,1.04))
+9 ; site ID (division)
SET YSCLARR("SITE_ID")=YSITE
+10 SET YSCLARR("SITE_STATION")=$EXTRACT($GET(^TMP($JOB,"YS file#4",YSITE,99)),1,3)
+11 ; one time lookups per site
+12 Begin DoDot:1
+13 SET X=+$GET(^TMP($JOB,"YS deflt outpt site"))
if X
QUIT
+14 ; file #59 pointer
SET X=$$GET1^DIQ(59.7,1,40,"I")
+15 ; one time lookup
SET ^TMP($JOB,"YS deflt outpt site")=X
End DoDot:1
SET YSCLARR("SITE_DEFAULT OUTPATIENT SITE")=X
+16 ;
+17 Begin DoDot:1
+18 SET X=+$GET(^TMP($JOB,"YS site dea#"))
if X
QUIT
+19 ;Facility DEA number
SET X=$$GET1^DIQ(4,YSITE,52)
+20 SET ^TMP($JOB,"YS site dea#")=X
End DoDot:1
SET YSCLARR("SITE_DEFAULT OUTPATIENT SITE")=X
+21 ;
+22 Begin DoDot:1
+23 NEW YSDIV
SET YSDIV=+$GET(YSCLARR("MED_PHARMACY DIVISION"))
+24 ;ajf removed +$G to allow leading zeros for NCPDP
+25 SET X=$GET(^TMP($JOB,"YS pharmacy ncpdp",YSDIV))
if X
QUIT
+26 SET X=$$NCPDPF59(YSDIV)
+27 SET ^TMP($JOB,"YS pharmacy ncpdp",YSDIV)=X
End DoDot:1
SET YSCLARR("SITE_PHARMACY NCPDP")=X
+28 QUIT
+29 ;
STINFO(YSFL4IEN) ; institution lookup
+1 ; already got it
if $DATA(^TMP($JOB,"YS file#4",YSFL4IEN))
QUIT
+2 NEW YSFLD
FOR YSFLD=.01,.02,1.01,1.02,1.03,1.04,99
SET ^TMP($JOB,"YS file#4",YSFL4IEN,YSFLD)=$$GET1^DIQ(4,YSFL4IEN,YSFLD)
+3 QUIT
+4 ;
DFLTVLUS(YSCLARR) ;
+1 ; default values for inpatient and outpatient
+2 SET YSCLARR("DISPAMT")=""
+3 SET YSCLARR("DISPUNITS")=""
+4 SET YSCLARR("DISPQTY")=""
+5 SET YSCLARR("DISPQTYUNIT")=""
+6 SET YSCLARR("MED_REASON CODE")=""
+7 SET YSCLARR("MED_REASON TEXT")=""
+8 SET YSCLARR("MED_ALTERNATE REASON CODE")=""
+9 SET YSCLARR("MED_ALTERNATE REASON TEXT")=""
+10 SET YSCLARR("MED_DOSE")=""
+11 SET YSCLARR("MED_STATUS")=""
+12 SET YSCLARR("MED_RX#/ORDER#")=""
+13 SET YSCLARR("MED_PRESCRIBING DATE")=""
+14 ;ajf ; Add Approving provider
+15 SET YSCLARR("MED_APPROVING PROVIDER")=""
+16 SET YSCLARR("MED_APPROVING PROVIDER_LAST NAME")=""
+17 SET YSCLARR("MED_APPROVING PROVIDER_FIRST NAME")=""
+18 SET YSCLARR("MED_APPROVING PROVIDER DEA")=""
+19 SET YSCLARR("MED_APPROVING PROVIDER IEN")=""
+20 ; INSTITUTION file (#4) values
+21 SET YSCLARR("MED_DIVISION:INSTITUTION PTR")=""
+22 SET YSCLARR("SITE_FILE #4 IEN")=""
+23 QUIT
+24 ;
DATEEX(YSCLDATE) ; Convert FileMan date to YYYYMMDD format
+1 NEW Y,YSCLMMDD
+2 SET Y=YSCLDATE
+3 SET Y=$PIECE(YSCLDATE,".",1)
+4 IF Y'?7N
QUIT ""
+5 SET YSCLMMDD=$EXTRACT(YSCLDATE,4,7)
+6 DO DD^%DT
+7 SET YSCLDATE=$EXTRACT($PIECE(Y,",",2),2,5)
+8 SET YSCLDATE=YSCLDATE_YSCLMMDD
+9 QUIT YSCLDATE
