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

PSSHL1.m

Go to the documentation of this file. 
  1. PSSHL1 ;BIR/RLW/WRT-BUILD HL7 MESSAGE TO POPULATE ORDERABLE ITEM FILE ;09/08/97
  1.  ;;1.0;PHARMACY DATA MANAGEMENT;**38,68,125**;9/30/97;Build 2
  1.  ;External reference to ORD(101 supported by DBIA 872
  1.  ; PSJEC=event code from HL7 table 8.4.2.1
  1.  ; PSJSPIEN=ien to super-primary drug file (#50.7)
  1.  ; SPDNAME=.01 field (name) of super-primary drug
  1.  ; LIMIT=number of fields in HL7 segment being built
  1.  ;
  1.  W !!?3,"This routine should not be accessed through programmer mode!",!
  1.  Q
  1. EN1 ; start here for pre-install auto load
  1.  N MENU,MENUP,ITEM
  1.  D PRO Q:$G(XPDABORT)
  1.  S PSSMFU=+$O(^PS(59.7,0)) I $P(^PS(59.7,PSSMFU,80),"^",2)=4 K PSSMFU Q
  1.  N APPL,CODE,FIELD,LIMIT,MFE,PSJI,SEGMENT,SPDNAME,SYN,SYNONYM,USAGE,X
  1.  I '$D(^XTMP("PSO_V7 INSTALL",0)) S X1=DT,X2=+7 D C^%DTC S ^XTMP("PSO_V7 INSTALL",0)=DT_"^"_X_"^OUTPATIENT V7 KIDS INSTALL" L +^XTMP("PSO_V7 INSTALL",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) G SKIP
  1.  F  Q:'$D(^XTMP("PSO_V7 INSTALL",0))  L +^XTMP("PSO_V7 INSTALL",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) Q:$T
  1.  I '$D(^XTMP("PSO_V7 INSTALL",0)) S X1=DT,X2=+7 D C^%DTC S ^XTMP("PSO_V7 INSTALL",0)=DT_"^"_X_"^OUTPATIENT V7 KIDS INSTALL" L +^XTMP("PSO_V7 INSTALL",0):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
  1.  I $P(^PS(59.7,PSSMFU,80),"^",2)=4 L -^XTMP("PSO_V7 INSTALL",0) K ^XTMP("PSO_V7 INSTALL",0) Q
  1. SKIP ;
  1.  S PSJEC="MAD",CODE="REP"
  1.  D INIT
  1.  D LOOP,MF^PSSHLU(PSJI)
  1.  S PSLSITE=+$O(^PS(59.7,0)) S $P(^PS(59.7,PSLSITE,80),"^",2)=4 K PSLSITE
  1.  L -^XTMP("PSO_V7 INSTALL",0) K ^XTMP("PSO_V7 INSTALL",0)
  1.  K ^TMP("HLS",$J,"PS"),PSJEC,PSJSPIEN,PSJCLEAR,PSSMFU Q
  1.  ;
  1. EN2(PSJSPIEN,PSJEC) ; start here for "manual" update
  1.  S PSLSITE=+$O(^PS(59.7,0)) I +$P($G(^PS(59.7,PSLSITE,80)),"^",2)<4 K PSLSITE Q
  1.  ; passed in: internal entry # of super-primary drug, entry code
  1.  S:'$P($G(^PS(50.7,PSJSPIEN,0)),"^",4) PSJEC="MAC"
  1.  K PSLSITE N APPL,CODE,FIELD,PSJI,LIMIT,MFE,SEGMENT,SPDNAME,SYN,SYNONYM,USAGE,X,ZCOUNT,ZUSAGE
  1.  S CODE="UPD"
  1.  D INIT
  1.  D MFE(PSSIVID),MF^PSSHLU(PSJI)
  1.  K ^TMP("HLS",$J,"PS")
  1.  Q
  1.  ;
  1.  ;
  1. INIT ; initialize HL7 variables, set master file identification segment fields
  1.  S PSJI=0,LIMIT=6,HLMTN="MFN",PSSIVID=$$GTIVID()
  1.  D INIT^PSSHLU X PSJCLEAR
  1.  S FIELD(0)="MFI"
  1.  S FIELD(1)="50.7^PHARMACY ORDERABLE ITEM^99DD"
  1.  S FIELD(3)=CODE
  1.  S FIELD(6)="NE"
  1.  D SEGMENT^PSSHLU(LIMIT)
  1.  Q
  1.  ;
  1. LOOP ; loop through PHARMACY ORDERABLE ITEM file
  1.  ;F  L +^PS(59.7,PSSIVID,31) Q:$T  H 1
  1.  S PSJSPIEN=0 F  S PSJSPIEN=$O(^PS(50.7,PSJSPIEN)) Q:'PSJSPIEN  D MFE(PSSIVID)
  1.  ;L -^PS(59.7,PSSIVID,31)
  1.  Q
  1.  ;
  1. MFE(PSSIVID) ; set master file entry segment fields
  1.  ; Input: PSSIVID-IV Identifier
  1.  S LIMIT=4 X PSJCLEAR
  1.  S X=$G(^PS(50.7,PSJSPIEN,0))
  1.  S FIELD(0)="MFE"
  1.  S FIELD(1)=PSJEC
  1.  S FIELD(3)=$P($G(^PS(50.7,PSJSPIEN,0)),"^",4) I FIELD(3) S FIELD(3)=$$HLDATE^HLFNC(FIELD(3))
  1.  S FIELD(4)="^^^"_PSJSPIEN_"^"_$P(X,"^")_"~"_$P($G(^PS(50.606,$P(X,"^",2),0)),"^")_"~"_$S($P($G(^PS(50.7,PSJSPIEN,0)),"^",3):$G(PSSIVID),1:"")_"^99PSP"
  1.  D SEGMENT^PSSHLU(LIMIT)
  1.  D ZPS,ZSY
  1.  Q
  1.  ;
  1. ZPS ; get USAGE from dispense drug(s), set ZPS segment
  1.  S LIMIT=2 X PSJCLEAR
  1.  S FIELD(0)="ZPS"
  1.  S USAGE=$$USAGE^PSSHLU(PSJSPIEN)
  1.  Q:USAGE=""&('$P($G(^PS(50.7,PSJSPIEN,0)),"^",9))&('$P($G(^PS(50.7,PSJSPIEN,0)),"^",12))
  1.  F I="I","O","A","B","V" S:+$P(USAGE,I,2)>0 FIELD(1)=FIELD(1)_I
  1.  S:$P($G(^PS(50.7,PSJSPIEN,0)),"^",9) FIELD(1)=FIELD(1)_"S"
  1.  S:$P($G(^PS(50.7,PSJSPIEN,0)),"^",10) FIELD(1)=FIELD(1)_"N"
  1.  S:$P($G(^PS(50.7,PSJSPIEN,0)),"^",12) FIELD(2)=1
  1.  D SEGMENT^PSSHLU(LIMIT)
  1.  Q
  1.  ;
  1. ZSY ; get SYNONYMs
  1.  S LIMIT=2 X PSJCLEAR
  1.  S FIELD(0)="ZSY"
  1.  S SYNONYM="",(J,SYNIEN)=0 F  S SYNIEN=$O(^PS(50.7,PSJSPIEN,2,SYNIEN)) Q:'SYNIEN  S SYNONYM=$P($G(^(SYNIEN,0)),"^") Q:SYNONYM=""  D
  1.  .S FIELD(1)="1",FIELD(2)=SYNONYM D SEGMENT^PSSHLU(LIMIT)
  1.  Q
  1. PRO ;Check for protocols
  1.  S MENU="PS MFSEND OR",ITEM="OR ITEM RECEIVE",MENUP=$O(^ORD(101,"B",MENU,0))
  1.  S X=$O(^ORD(101,"B",ITEM,0)) I 'X W !!?5,"Sorry, you need the OR ITEM RECEIVE protocol to proceed,",!?5,"which is exported with Order Entry/Results Reporting V3!",! S XPDABORT=1 Q
  1.  Q:$D(^ORD(101,MENUP,10,"B",X))
  1.  I $D(^ORD(101,MENUP,10,0))[0 S ^ORD(101,MENUP,10,0)="^"_"101.01PA"
  1.  K DD,DA,DO,DIC S DIC="^ORD(101,"_MENUP_",10,",DIC(0)="L",DLAYGO=101.01,DA(1)=MENUP D FILE^DICN K DD,DO
  1.  K DIC I Y<0 W !!?5,"Sorry, unable to add OR ITEM RECEIVE protocol as an Item to the PS MFSEND",!,"protocol, cannot proceed!",! S XPDABORT=1
  1.  Q
  1. ENIVID ; Edit IV Identifier field to be displayed with IV Orderable Items.
  1.  Q
  1.  N DA,DIC,DIE,DRG,PSSOI,PSSIVID,PSSFIL,PSSDRG,X,Y
  1.  S DIC=59.7,DIC(0)="AEMQ" D ^DIC Q:Y<0
  1.  W !!!,"Changing the IV Identifier will update the name of ALL Orderable Items",!,"marked as an IV!",!!
  1.  S PSSIVID=$P($G(^PS(59.7,+Y,31)),U,2),DIE=59.7,(DA,PSSSITE)=+Y,DR=32 D ^DIE
  1.  Q:PSSIVID=$P($G(^PS(59.7,PSSSITE,31)),U,2)
  1.  W !!,"Updating Orderable Item names in OE/RR"
  1.  F PSSOI=0:0 S PSSOI=$O(^PS(50.7,"AIV",1,PSSOI)) Q:'PSSOI  D:$D(^PS(50.7,PSSOI)) EN2^PSSHL1(PSSOI,"MUP") W "."
  1.  ;F PSSFIL=52.6,52.7 F PSSOI=0:0 S PSSOI=$O(^PS(PSSFIL,"AOI",PSSOI)) Q:'PSSOI  D:$D(^PS(50.7,PSSOI)) EN2^PSSHL1(PSSOI,"MUP") W "."
  1.  Q
  1.  ;
  1. GTIVID() ; Return IV Identifier. If being edited, wait until edit is done.
  1.  N X,PX S (X,PX)=$O(^PS(59.7,0)) Q:'X
  1.  F  L +^PS(59.7,X,31):$S($G(DILOCKTM)>0:DILOCKTM,1:3) Q:$T  H 2
  1.  S X=$P($G(^PS(59.7,X,31)),U,2)
  1.  L -^PS(59.7,PX,31)
  1.  Q X