Context Navigation

← Previous Change
Next Change →

BAR_CODE_MED_ADMIN-ALPB-PSB

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

Location:

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB

Files:

: 9 edited

ALPBGEN1.m (modified) (1 diff)
ALPBINP.m (modified) (1 diff)
ALPBPWRD.m (modified) (1 diff)
ALPBUTL1.m (modified) (1 diff)
PSBO.m (modified) (1 diff)
PSBO1.m (modified) (1 diff)
PSBOMH1.m (modified) (1 diff)
PSBPOIV.m (modified) (1 diff)
PSBRPC2.m (modified) (1 diff)

Legend:

: Unmodified
: Added
: Removed

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m

-              r613
+              r623
+ALPBGEN1        ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
+        ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
+        ;;Per VHA Directive 2004-038, this routine should not be modified.
+        Q
+        ;
+PARSIT  ;PARSE MESSAGE ON RECEIVING SIDE
+        N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
+        S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS=""  ;Field separator
+        S EC=$G(HL("ECH")) Q:EC=""  ;Encoding Charaters
+        S CS=$E(EC) ;Component separator
+        S RS=$E(EC,2) ;Repitition separator
+        S ESC=$E(EC,3) ;Escape character
+        S SS=$E(EC,4) ;Subcomponent separator
+        S EEC=ESC_"E"_ESC ;escaped escape character
+        S EFS=ESC_"F"_ESC ;escaped field sep
+        S ECS=ESC_"S"_ESC ;escaped component sep
+        S ERS=ESC_"R"_ESC ; escaped repitition sep
+        S ESS=ESC_"T"_ESC ;escaped subcomponent separator
+        N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
+        F  X HLNEXT Q:$G(HLQUIT)'>0  D
+        . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
+        . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
+        Q
+PSTF    ;Process STF segment
+        S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
+        S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
+        . S ALPBSSN=$TR(ALPBSSN,"-","")
+        . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
+        . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
+        . ;Unescape Access Code
+        . S ALPBAC=$$UNESC(ALPBAC)
+        . ;Unescape Verify Code
+        . S ALPBVC=$$UNESC(ALPBVC)
+        S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM["  " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME"
+        I $D(ALERR) G PERR
+        S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
+        I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
+FILE    ;Store File 200 data on backup system
+        N Y,DIC,DIE,DA,DR
+        Q:'$D(ALPBNAM)
+        Q:$L(ALPBSSN)'=9
+        ;Try exact SSn lookup first
+        K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
+        ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
+        ;If SSN lookup fails, try name lookup and add
+        I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
+        I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
+        . S DIE="^VA(200,",DR="2////^S X=ALPBAC"
+        . ;Update name too
+        . S DR=DR_";.01////^S X=ALPBNAM"
+        . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
+        . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
+        . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
+        . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
+        . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
+        . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
+        K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
+        Q
+UNESC(ST,PR)    ;Unescape string from message
+        ;ST=String to translate
+        ;PR=Event Protocol to set up HL array variables (optional)
+        ;First, do the escape character
+        I $G(ST)="" Q ""
+        S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
+        I '$D(HL) D
+        . S HL("FS")="^"
+        . S HL("ECH")="~|\&"
+        S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
+        S EC=$G(HL("ECH")) I EC="" Q ""  ;Encoding Charaters
+        S CS=$E(EC) ;Component separator
+        S RS=$E(EC,2) ;Repitition separator
+        S ESC=$E(EC,3) ;Escape character
+        S SS=$E(EC,4) ;Subcomponent separator
+        S EEC=ESC_"E"_ESC ;escaped escape character
+        S EFS=ESC_"F"_ESC ;escaped field sep
+        S ECS=ESC_"S"_ESC ;escaped component sep
+        S ERS=ESC_"R"_ESC ; escaped repitition sep
+        S ESS=ESC_"T"_ESC ;escaped subcomponent separator
+        K I,J,K,L,X F  S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
+        S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I)
+        I $G(L)]"" S ST=L
+        ;
+        K I,J,K,L,X F  S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
+        S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I)
+        I $G(L)]"" S ST=L
+        ;
+        K I,J,K,L,X S I=0 F  S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
+        S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I)
+        I $G(L)]"" S ST=L
+        ;
+        K I,J,K,L,X S I=0 F  S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
+        S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I)
+        I $G(L)]"" S ST=L
+        ;
+        K I,J,K,L,X S I=0 F  S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
+        S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I)
+        I $G(L)]"" S ST=L
+        K I,J,K,L,X
+        Q ST
+PERR    ;PROCESSING ERRORS
+        H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
+        K ALERR
+        Q
+ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003  07:59
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+ Q
+ ;
+PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
+ N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
+ S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS=""  ;Field separator
+ S EC=$G(HL("ECH")) Q:EC=""  ;Encoding Charaters
+ S CS=$E(EC) ;Component separator
+ S RS=$E(EC,2) ;Repitition separator
+ S ESC=$E(EC,3) ;Escape character
+ S SS=$E(EC,4) ;Subcomponent separator
+ S EEC=ESC_"E"_ESC ;escaped escape character
+ S EFS=ESC_"F"_ESC ;escaped field sep
+ S ECS=ESC_"S"_ESC ;escaped component sep
+ S ERS=ESC_"R"_ESC ; escaped repitition sep
+ S ESS=ESC_"T"_ESC ;escaped subcomponent separator
+ N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
+ F  X HLNEXT Q:$G(HLQUIT)'>0  D
+ . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
+ . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
+ Q
+PSTF ;Process STF segment
+ S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
+ S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
+ . S ALPBSSN=$TR(ALPBSSN,"-","")
+ . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
+ . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
+ . ;Unescape Access Code
+ . S ALPBAC=$$UNESC(ALPBAC)
+ . ;Unescape Verify Code
+ . S ALPBVC=$$UNESC(ALPBVC)
+ S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM["  " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME"
+ I $D(ALERR) G PERR
+ S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
+ I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
+FILE ;Store File 200 data on backup system
+ N Y,DIC,DIE,DA,DR
+ Q:'$D(ALPBNAM)
+ Q:$L(ALPBSSN)'=9
+ ;Try exact SSn lookup first
+ K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
+ ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
+ ;If SSN lookup fails, try name lookup and add
+ I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
+ I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
+ . S DIE="^VA(200,",DR="2////^S X=ALPBAC"
+ . ;Update name too
+ . S DR=DR_";.01////^S X=ALPBNAM"
+ . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
+ . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
+ . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
+ . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
+ . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
+ . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
+ K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
+ Q
+UNESC(ST,PR) ;Unescape string from message
+ ;ST=String to translate
+ ;PR=Event Protocol to set up HL array variables (optional)
+ ;First, do the escape character
+ I $G(ST)="" Q ""
+ S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
+ I '$D(HL) D
+ . S HL("FS")="^"
+ . S HL("ECH")="~|\&"
+ S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
+ S EC=$G(HL("ECH")) I EC="" Q ""  ;Encoding Charaters
+ S CS=$E(EC) ;Component separator
+ S RS=$E(EC,2) ;Repitition separator
+ S ESC=$E(EC,3) ;Escape character
+ S SS=$E(EC,4) ;Subcomponent separator
+ S EEC=ESC_"E"_ESC ;escaped escape character
+ S EFS=ESC_"F"_ESC ;escaped field sep
+ S ECS=ESC_"S"_ESC ;escaped component sep
+ S ERS=ESC_"R"_ESC ; escaped repitition sep
+ S ESS=ESC_"T"_ESC ;escaped subcomponent separator
+ K I,J,K,L,X F  S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
+ S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I)
+ I $G(L)]"" S ST=L
+ ;
+ K I,J,K,L,X F  S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X
+ S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I)
+ I $G(L)]"" S ST=L
+ ;
+ K I,J,K,L,X S I=0 F  S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
+ S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I)
+ I $G(L)]"" S ST=L
+ ;
+ K I,J,K,L,X S I=0 F  S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
+ S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I)
+ I $G(L)]"" S ST=L
+ ;
+ K I,J,K,L,X S I=0 F  S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X
+ S I=0 F  S I=$O(K(I)) Q:I<1  S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I)
+ I $G(L)]"" S ST=L
+ K I,J,K,L,X
+ Q ST
+PERR ;PROCESSING ERRORS
+ H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
+ K ALERR
+ Q

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m

-              r613
+              r623
+ALPBINP ;OIFO-DALLAS/SED/KC/MW  BCMA - BCBU INPT TO HL7 ;5/2/2002
+        ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
+        ;;Per VHA Directive 2004-038, this routine should not be modified.
+        ;This routine will intercept the HL7 message that it sent from Pharmacy
+        ;to CPRS to update order information. The message is then parsed and
+        ;repackage so it can be sent to the BCBU workstation.
+        ;
+        ; Reference/IA
+        ; EN^PSJBCBU/3876
+        ; $$EN^VAFHLPID/263
+        ; $$EN^VAFHAPV1/4512
+        ; EN1^GMRADPT/10099
+        ; EN^PSJBCMA1/2829
+        ;
+IPH(MSG)        ;CAPTURE MESSAGE ARRAY FROM PHARMACY
+        N VAIN,ALPMSG
+        S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
+        I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
+        S MSH=0
+        F  S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0  Q:$E(@ALPMSG@(MSH),1,3)="MSH"
+        I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
+        S MSFS=$E(@ALPMSG@(MSH),4,4)
+        S MSCS=$E(@ALPMSG@(MSH),5,5)
+        S MSCH=$E(@ALPMSG@(MSH),6,6)
+        S MSCTR=$E(@ALPMSG@(MSH),4,8)
+        ;The message is confirmed to be a Pharmacy message
+        I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
+        ;A PID and PV1 segment is required for this message
+        S PID=0
+        F  S PID=$O(@ALPMSG@(PID)) Q:PID'>0  Q:$E(@ALPMSG@(PID),1,3)="PID"
+        I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
+        ;Also the patient must have an inpatient status
+        S PV1=0
+        F  S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0  Q:$E(@ALPMSG@(PV1),1,3)="PV1"
+        I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
+        I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
+        S ORC=0
+        F  S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0  Q:$E(@ALPMSG@(ORC),1,3)="ORC"
+        I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
+        ;RE-BUILDING THE MESSAGE FOR BCBU
+        S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
+        I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
+        S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
+        I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
+        K ALPB
+        D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
+SEED    ;Entry point for ^ALPBIND
+        N VAIN
+        D INIT
+        S SUB=0 F  S SUB=$O(ALPB(SUB)) Q:'SUB  D
+        . ;convert and move the message to the HLA array for transport
+        . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
+        . ;Now check for continuations
+        . S SUB1=0
+        . F  S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1  D
+        . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
+        . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
+        . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
+        . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
+        K HLA("HLS",MSH)
+        I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
+        S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
+        I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
+        S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+        ;Fix RXE segement for Administration Type
+        D RXE
+        ;Get the Division that the patient is associated with
+        D PDIV
+        I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
+        I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
+        ;SET NEW PV1
+        D NOW^%DTC
+        S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
+        S HLA("HLS",PV1)=STRING
+        I +ORC>0 D
+        . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
+        . Q:ALPST=""
+        . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
+        D AL1
+        ;Capture message to review for testing before sending
+        D SEND
+EXIT    ;EXIT and kill
+        K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
+        K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
+        K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
+        K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
+        Q ALPRSLT
+INI()   ;INTIAL SET UP ENTRY
+        G SEED
+INIT    ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
+        ;SET UP ENVIRONMENT FOR MESSAGE
+        K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
+        S EVENT="PSB BCBU ORM SEND"
+        D INIT^HLFNC2(EVENT,.HL,1)
+        S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
+        Q
+SEND    ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
+        K ALPRSLT,ALPOPTS
+        D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
+        Q
+AL1     ;ALLERGY SEGMENT BUILD
+        ;The will build the ALP segment with the curent allergies
+        ;for the patient to be added to the message
+        N DFN
+        Q:+ALPDFN'>0
+        K GMRAL
+        S DFN=ALPDFN
+        S GMRA="0^0^111"  ;DEFINES WHAT ALLERGIES TO RETURN
+        D EN1^GMRADPT
+        Q:'$D(GMRAL)
+        S ALPI=0,ALPC=1,ALPSYM=""
+        F  S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0  D
+        . S ALPADR=""
+        . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
+        . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
+        . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
+        . ;S ALPII=0 F  S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0  D
+        . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
+        . ;S $P(ALPDATA,HLFS,6)=ALPSYM
+        . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
+        . S ALPC=ALPC+1
+        K GMRAL
+        Q
+RXE     ;
+        Q:+$G(RXE)'>0
+        K ^TMP("PSJ1",$J)
+        Q:'$D(HLA("HLS",RXE))
+        S DATA=HLA("HLS",RXE)
+        D EN^PSJBCMA1(ALPDFN,ALPORD,1)
+        S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
+        Q:TYP="CONTINUOUS"
+        Q:TYP="FILL ON REQUEST"
+        S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
+        I ALP1[TYP Q
+        I ALP2[TYP Q
+        S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
+        S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
+        S HLA("HLS",RXE)=DATA
+        K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
+        Q
+PDIV    ;PATIENT DIVISION
+        ;Check ALPBMDT Variable
+        S:+$G(ALPBMDT)'>0 ALPBMDT=0
+        S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
+        ;Screen Dom
+        I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
+        ;Now do I send the Message or not Based of Division
+        I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
+        I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
+        Q
+MEDL(ALPML)     ;Use this entry to send MedLog messages
+        N VAIN
+        ;ALPML is the IEN of the MedLog for file #53.79
+        I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
+        I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
+        ;First get the required HL7 Variables
+        D INIT
+        ;Need to build the PID, PV1 and ORC segments
+        S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
+        I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
+        ;Get the Division that the patient is associated with
+        D PDIV
+        I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
+        I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
+        S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
+        S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
+        S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
+        S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
+        S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
+        S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
+        I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
+        S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+        I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
+        S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+        I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
+        S HLA("HLS",1)=PID
+        S HLA("HLS",2)=PV1
+        ;BUILD ORC SEGMENT
+        S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
+        S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
+        S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
+        S HLA("HLS",3)=ORC
+        ;The Message is ready to send
+        D SEND
+        Q ALPRSLT
+        ;
+ADMQ    ;Need to que a single patient init for admissions
+        S ALDFN=ALPDFN
+        S ZTDTH=$$NOW^XLFDT
+        S ZTRTN="PAT^ALPBIND"
+        S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
+        S ZTIO="",ZTSAVE("ALDFN")=""
+        D ^%ZTLOAD
+        K ZTIO,ZTDESC,ZTRTN,ZTSK
+        Q
+PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT)       ;Entry Point to send patient movement
+        N VAIN
+        I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
+        D INIT
+        ;Check Movement type. If not a discharge then don't pass date and time
+        S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
+        ;Get the Division that the patient is associated with
+        D PDIV
+        I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
+        I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
+        S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+        S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+        S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
+        D SEND
+        I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
+        I $G(ALPTT)="ADMISSION" D ADMQ
+        ;SEND A DISCHARGE TO DIV SENDING ASIH
+        I $G(ALPTYP)[13!($G(ALPTYP)[40) D
+        .D INIT
+        .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
+        .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q  ;NO WARD
+        .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
+        .D GET^ALPBPARM(.HLL,ALPBDIV)
+        .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+        .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+        .S $P(HLA("HLS",2),HLFS,37)="ASIH"
+        .D SEND
+        Q ALPRSLT
+ALPBINP ;OIFO-DALLAS/SED/KC/MW  BCMA - BCBU INPT TO HL7 ;5/2/2002
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+ ;This routine will intercept the HL7 message that it sent from Pharmacy
+ ;to CPRS to update order information. The message is then parsed and
+ ;repackage so it can be sent to the BCBU workstation.
+ ;
+ ; Reference/IA
+ ; EN^PSJBCBU/3876
+ ; $$EN^VAFHLPID/263
+ ; $$EN^VAFHAPV1/4512
+ ; EN1^GMRADPT/10099
+ ; EN^PSJBCMA1/2829
+ ;
+IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
+ N VAIN,ALPMSG
+ S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
+ I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
+ S MSH=0
+ F  S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0  Q:$E(@ALPMSG@(MSH),1,3)="MSH"
+ I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
+ S MSFS=$E(@ALPMSG@(MSH),4,4)
+ S MSCS=$E(@ALPMSG@(MSH),5,5)
+ S MSCH=$E(@ALPMSG@(MSH),6,6)
+ S MSCTR=$E(@ALPMSG@(MSH),4,8)
+ ;The message is confirmed to be a Pharmacy message
+ I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
+ ;A PID and PV1 segment is required for this message
+ S PID=0
+ F  S PID=$O(@ALPMSG@(PID)) Q:PID'>0  Q:$E(@ALPMSG@(PID),1,3)="PID"
+ I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
+ ;Also the patient must have an inpatient status
+ S PV1=0
+ F  S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0  Q:$E(@ALPMSG@(PV1),1,3)="PV1"
+ I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
+ I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
+ S ORC=0
+ F  S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0  Q:$E(@ALPMSG@(ORC),1,3)="ORC"
+ I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
+ ;RE-BUILDING THE MESSAGE FOR BCBU
+ S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
+ I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
+ S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
+ I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
+ K ALPB
+ D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
+SEED ;Entry point for ^ALPBIND
+ D INIT
+ S SUB=0 F  S SUB=$O(ALPB(SUB)) Q:'SUB  D
+ . ;convert and move the message to the HLA array for transport
+ . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
+ . ;Now check for continuations
+ . S SUB1=0
+ . F  S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1  D
+ . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
+ . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
+ . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
+ . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
+ K HLA("HLS",MSH)
+ I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
+ S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
+ I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
+ S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+ ;Fix RXE segement for Administration Type
+ D RXE
+ ;Get the Division that the patient is associated with
+ D PDIV
+ I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
+ I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
+ ;SET NEW PV1
+ D NOW^%DTC
+ S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
+ S HLA("HLS",PV1)=STRING
+ I +ORC>0 D
+ . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
+ . Q:ALPST=""
+ . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
+ D AL1
+ ;Capture message to review for testing before sending
+ D SEND
+EXIT ;EXIT and kill
+ K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
+ K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
+ K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
+ K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
+ Q ALPRSLT
+INI() ;INTIAL SET UP ENTRY
+ G SEED
+INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
+ ;SET UP ENVIRONMENT FOR MESSAGE
+ K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
+ S EVENT="PSB BCBU ORM SEND"
+ D INIT^HLFNC2(EVENT,.HL,1)
+ S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
+ Q
+SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
+ K ALPRSLT,ALPOPTS
+ D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
+ Q
+AL1 ;ALLERGY SEGMENT BUILD
+ ;The will build the ALP segment with the curent allergies
+ ;for the patient to be added to the message
+ N DFN
+ Q:+ALPDFN'>0
+ K GMRAL
+ S DFN=ALPDFN
+ S GMRA="0^0^111"  ;DEFINES WHAT ALLERGIES TO RETURN
+ D EN1^GMRADPT
+ Q:'$D(GMRAL)
+ S ALPI=0,ALPC=1,ALPSYM=""
+ F  S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0  D
+ . S ALPADR=""
+ . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
+ . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
+ . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
+ . ;S ALPII=0 F  S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0  D
+ . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
+ . ;S $P(ALPDATA,HLFS,6)=ALPSYM
+ . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
+ . S ALPC=ALPC+1
+ K GMRAL
+ Q
+RXE ;
+ Q:+$G(RXE)'>0
+ K ^TMP("PSJ1",$J)
+ Q:'$D(HLA("HLS",RXE))
+ S DATA=HLA("HLS",RXE)
+ D EN^PSJBCMA1(ALPDFN,ALPORD,1)
+ S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
+ Q:TYP="CONTINUOUS"
+ Q:TYP="FILL ON REQUEST"
+ S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
+ I ALP1[TYP Q
+ I ALP2[TYP Q
+ S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
+ S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
+ S HLA("HLS",RXE)=DATA
+ K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
+ Q
+PDIV ;PATIENT DIVISION
+ ;Check ALPBMDT Variable
+ S:+$G(ALPBMDT)'>0 ALPBMDT=0
+ S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
+ ;Screen Dom
+ Q:ALPDIV="DOM"
+ ;Now do I send the Message or not Based of Division
+ I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
+ I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
+ Q
+MEDL(ALPML) ;Use this entry to send MedLog messages
+ N VAIN
+ ;ALPML is the IEN of the MedLog for file #53.79
+ I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
+ I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
+ ;First get the required HL7 Variables
+ D INIT
+ ;Need to build the PID, PV1 and ORC segments
+ S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
+ I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
+ ;Get the Division that the patient is associated with
+ D PDIV
+ I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
+ I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
+ S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
+ S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
+ S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
+ S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
+ S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
+ S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
+ I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
+ S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+ I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
+ S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+ I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
+ S HLA("HLS",1)=PID
+ S HLA("HLS",2)=PV1
+ ;BUILD ORC SEGMENT
+ S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
+ S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
+ S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
+ S HLA("HLS",3)=ORC
+ ;The Message is ready to send
+ D SEND
+ Q ALPRSLT
+ ;
+ADMQ ;Need to que a single patient init for admissions
+ S ALDFN=ALPDFN
+ S ZTDTH=$$NOW^XLFDT
+ S ZTRTN="PAT^ALPBIND"
+ S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
+ S ZTIO="",ZTSAVE("ALDFN")=""
+ D ^%ZTLOAD
+ K ZTIO,ZTDESC,ZTRTN,ZTSK
+ Q
+PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
+ N VAIN
+ I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
+ D INIT
+ ;Check Movement type. If not a discharge then don't pass date and time
+ S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
+ ;Get the Division that the patient is associated with
+ D PDIV
+ I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
+ I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
+ S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+ S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+ S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
+ D SEND
+ I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
+ I $G(ALPTT)="ADMISSION" D ADMQ
+ ;SEND A DISCHARGE TO DIV SENDING ASIH
+ I $G(ALPTYP)[13!($G(ALPTYP)[40) D
+ .D INIT
+ .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
+ .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q  ;NO WARD
+ .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
+ .D GET^ALPBPARM(.HLL,ALPBDIV)
+ .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+ .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+ .S $P(HLA("HLS",2),HLFS,37)="ASIH"
+ .D SEND
+ Q ALPRSLT

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m

-              r613
+              r623
+ALPBPWRD        ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
+        ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
+        ;;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ; NOTE: this routine is designed for hard-copy output.
+        ;      Output is formatted for 132-column printing.
+        ;
+        F  D  Q:$D(DIRUT)
+        .W !,"Inpatient Pharmacy Orders for a selected ward"
+        .S DIR(0)="FAO^2:10"
+        .S DIR("A")="Select WARD: "
+        .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
+        .D ^DIR K DIR
+        .I $D(DIRUT) Q
+        .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
+        .I +$G(ALPBSEL(0))=0 D  Q
+        ..W $C(7)
+        ..W "  ??"
+        ..D WARDLIST^ALPBUTL("C")
+        ..K ALPBSEL
+        .I +$G(ALPBSEL(0))=1 D
+        ..S ALPBWARD=ALPBSEL(1)
+        ..W "   ",ALPBWARD
+        ..K ALPBSEL
+        .I +$G(ALPBSEL(0))>1 D  I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
+        ..S ALPBX=0
+        ..F  S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX  W !?2,$J(ALPBX,2),"  ",ALPBSEL(ALPBX)
+        ..K ALPBX
+        ..S DIR(0)="NA^1:"_ALPBSEL(0)
+        ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
+        ..W ! D ^DIR K DIR
+        ..I $D(DIRUT) K ALPBSEL Q
+        ..S ALPBWARD=ALPBSEL(+Y)
+        ..K ALPBSEL
+        .;
+        .; get all or just current orders?...
+        .S DIR(0)="SA^A:ALL;C:CURRENT"
+        .S DIR("A")="Report [A]LL or [C]URRENT orders? "
+        .S DIR("B")="CURRENT"
+        .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
+        .W ! D ^DIR K DIR
+        .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
+        .S ALPBOTYP=Y
+        .;
+        .;SORT BY NAME OR ROOM/BED     added 6/23/05
+        .S DIR(0)="SA^N:Name;R:Room/Bed"
+        .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
+        .S DIR("B")="Room/bed"
+        .S DIR("?")="Sort by [N]ame or [R]oom Bed"
+        .W ! D ^DIR K DIR
+        .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
+        .S ALPBSORT=Y
+        .;
+        .; print how many days MAR?...
+        .S DIR(0)="NA^1:7"
+        .S DIR("A")="Print how many days MAR? "
+        .S DIR("B")=$$DEFDAYS^ALPBUTL()
+        .S DIR("?")="The default is shown; you may enter 3 or 7."
+        .W ! D ^DIR K DIR
+        .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
+        .S ALPBDAYS=+Y
+        .;
+        .; BCMA Med Log info for how many ?...
+        .S DIR(0)="NA^1:99"
+        .S DIR("B")=$$DEFML^ALPBUTL3()
+        .S DIR("A")="Select how many BCMA Medication Log history: "
+        .S DIR("A",1)=" "
+        .S DIR("?",1)="Select a number of BCMA Medication log entries"
+        .S DIR("?",2)="for each of the patient's orders"
+        .S DIR("?")="They are listed by the most current entry first"
+        .D ^DIR K DIR
+        .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
+        .S ALPBMLOG=Y
+        .;
+        .S %ZIS="Q"
+        .S %ZIS("B")=$$DEFPRT^ALPBUTL()
+        .I %ZIS("B")="" K %ZIS("B")
+        .W ! D ^%ZIS K %ZIS
+        .I POP D  Q
+        ..W $C(7)
+        ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
+        .;
+        .; output not queued...
+        .I '$D(IO("Q")) D
+        ..U IO
+        ..D DQ
+        ..I IO'=IO(0) D ^%ZISC
+        .;
+        .; set up the Task...
+        .I $D(IO("Q")) D
+        ..S ZTRTN="DQ^ALPBPWRD"
+        ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
+        ..S ZTSAVE("ALPBDAYS")=""
+        ..S ZTSAVE("ALPBWARD")=""
+        ..S ZTSAVE("ALPBMLOG")=""
+        ..S ZTSAVE("ALPBOTYP")=""
+        ..S ZTSAVE("ALPBSORT")=""
+        ..S ZTIO=ION
+        ..D ^%ZTLOAD
+        ..D HOME^%ZIS
+        ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+        ..K IO("Q"),ZTSK
+        .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
+        K DIRUT,DTOUT,X,Y
+        Q
+        ;
+DQ      ; output entry point...
+        K ^TMP($J)
+        ;
+        ; set report date...  SED 11/4/03
+        S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
+        ;
+        ; loop through ward cross reference in 53.7...
+        S ALPBPTN=""
+        F  S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""  D
+        .S ALPBIEN=0
+        .F  S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+        ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
+        ..I +ALPBORDS(0)'>0 K ALPBORDS Q
+        ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
+        ..S ALPBOIEN=0
+        ..F  S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN  D
+        ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
+        ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
+        ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
+        ...; if report is for "C"urrent, check stop date and quit if
+        ...; stop date is less than report date...
+        ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
+        ...S ALPBORDN=ALPBORDS(ALPBOIEN)
+        ...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
+        ...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
+        ...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
+        ...K ALPBDATA,ALPBORDN,ALPBOST
+        ..K ALPBOIEN,ALPBORDS,ALPBPDAT
+        .K ALPBIEN
+        K ALPBPTN
+        ;
+        ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
+        S ALPBPG=0
+        S ALPBPTN=""
+        I ALPBSORT="N" D
+        .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  S ALPBIEN=^TMP($J,ALPBPTN) D PRT
+        ;SORT BY ROOM/BED
+        I ALPBSORT="R" D
+        .S ALPBD="",ALPRM=""
+        .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D  Q:ALPBPTN=""
+        ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
+        ..I ALPBPTN="" Q  ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
+        ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
+        ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
+        ..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
+        .S ALPRM1="" F  S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1=""  D
+        ..S ALPRM="" F  S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM=""  D
+        ...S ALPBD="" F  S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD=""  D
+        ....S ALPBPTN="" F  S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN=""  D
+        .....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))  D PRT
+        D DONE
+        Q
+PRT     S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
+        M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
+        I ALPBPG=0 D PAGE
+        S ALPBOCT=""
+        F  S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT=""  D
+        .S ALPBOST=""
+        .F  S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST=""  D
+        ..S ALPBORDN=""
+        ..F  S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN=""  D
+        ...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
+        ...; get and print this order's data...
+        ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+        ...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+        ...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
+        ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
+        ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
+        ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
+        ..K ALPBORDN
+        .K ALPBOST
+        K ALPBOCT
+        ; print footer at end of this patient's record...
+        I $Y+10>IOSL D PAGE
+        W !!
+        D FOOT^ALPBFRMU
+        ;Print a blank page between patient
+        W @IOF
+        S ALPBPG=0
+        K ALPBPDAT
+        Q
+        ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
+        ;
+DONE    ;
+        K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
+        I $D(ZTQUEUED) S ZTREQ="@"
+        Q
+        ;
+PAGE    ; print page header for patient...
+        W @IOF
+        S ALPBPG=ALPBPG+1
+        D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
+        F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
+        K ALPBHDR,ALPBX
+        Q
+ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+ ;
+ ; NOTE: this routine is designed for hard-copy output.
+ ;      Output is formatted for 132-column printing.
+ ;
+ F  D  Q:$D(DIRUT)
+ .W !,"Inpatient Pharmacy Orders for a selected ward"
+ .S DIR(0)="FAO^2:10"
+ .S DIR("A")="Select WARD: "
+ .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
+ .D ^DIR K DIR
+ .I $D(DIRUT) Q
+ .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
+ .I +$G(ALPBSEL(0))=0 D  Q
+ ..W $C(7)
+ ..W "  ??"
+ ..D WARDLIST^ALPBUTL("C")
+ ..K ALPBSEL
+ .I +$G(ALPBSEL(0))=1 D
+ ..S ALPBWARD=ALPBSEL(1)
+ ..W "   ",ALPBWARD
+ ..K ALPBSEL
+ .I +$G(ALPBSEL(0))>1 D  I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
+ ..S ALPBX=0
+ ..F  S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX  W !?2,$J(ALPBX,2),"  ",ALPBSEL(ALPBX)
+ ..K ALPBX
+ ..S DIR(0)="NA^1:"_ALPBSEL(0)
+ ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
+ ..W ! D ^DIR K DIR
+ ..I $D(DIRUT) K ALPBSEL Q
+ ..S ALPBWARD=ALPBSEL(+Y)
+ ..K ALPBSEL
+ .;
+ .; get all or just current orders?...
+ .S DIR(0)="SA^A:ALL;C:CURRENT"
+ .S DIR("A")="Report [A]LL or [C]URRENT orders? "
+ .S DIR("B")="CURRENT"
+ .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
+ .W ! D ^DIR K DIR
+ .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
+ .S ALPBOTYP=Y
+ .;
+ .;SORT BY NAME OR ROOM/BED     added 6/23/05
+ .S DIR(0)="SA^N:Name;R:Room/Bed"
+ .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
+ .S DIR("B")="Room/bed"
+ .S DIR("?")="Sort by [N]ame or [R]oom Bed"
+ .W ! D ^DIR K DIR
+ .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
+ .S ALPBSORT=Y
+ .;
+ .; print how many days MAR?...
+ .S DIR(0)="NA^1:7"
+ .S DIR("A")="Print how many days MAR? "
+ .S DIR("B")=$$DEFDAYS^ALPBUTL()
+ .S DIR("?")="The default is shown; you may enter 3 or 7."
+ .W ! D ^DIR K DIR
+ .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
+ .S ALPBDAYS=+Y
+ .;
+ .; BCMA Med Log info for how many ?...
+ .S DIR(0)="NA^1:99"
+ .S DIR("B")=$$DEFML^ALPBUTL3()
+ .S DIR("A")="Select how many BCMA Medication Log history: "
+ .S DIR("A",1)=" "
+ .S DIR("?",1)="Select a number of BCMA Medication log entries"
+ .S DIR("?",2)="for each of the patient's orders"
+ .S DIR("?")="They are listed by the most current entry first"
+ .D ^DIR K DIR
+ .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
+ .S ALPBMLOG=Y
+ .;
+ .S %ZIS="Q"
+ .S %ZIS("B")=$$DEFPRT^ALPBUTL()
+ .I %ZIS("B")="" K %ZIS("B")
+ .W ! D ^%ZIS K %ZIS
+ .I POP D  Q
+ ..W $C(7)
+ ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
+ .;
+ .; output not queued...
+ .I '$D(IO("Q")) D
+ ..U IO
+ ..D DQ
+ ..I IO'=IO(0) D ^%ZISC
+ .;
+ .; set up the Task...
+ .I $D(IO("Q")) D
+ ..S ZTRTN="DQ^ALPBPWRD"
+ ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
+ ..S ZTSAVE("ALPBDAYS")=""
+ ..S ZTSAVE("ALPBWARD")=""
+ ..S ZTSAVE("ALPBMLOG")=""
+ ..S ZTSAVE("ALPBOTYP")=""
+ ..S ZTSAVE("ALPBSORT")=""
+ ..S ZTIO=ION
+ ..D ^%ZTLOAD
+ ..D HOME^%ZIS
+ ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
+ ..K IO("Q"),ZTSK
+ .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
+ K DIRUT,DTOUT,X,Y
+ Q
+ ;
+DQ ; output entry point...
+ K ^TMP($J)
+ ;
+ ; set report date...  SED 11/4/03
+ S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
+ ;
+ ; loop through ward cross reference in 53.7...
+ S ALPBPTN=""
+ F  S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""  D
+ .S ALPBIEN=0
+ .F  S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+ ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
+ ..I +ALPBORDS(0)'>0 K ALPBORDS Q
+ ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
+ ..S ALPBOIEN=0
+ ..F  S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN  D
+ ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
+ ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
+ ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
+ ...; if report is for "C"urrent, check stop date and quit if
+ ...; stop date is less than report date...
+ ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
+ ...S ALPBORDN=ALPBORDS(ALPBOIEN)
+ ...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
+ ...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
+ ...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
+ ...K ALPBDATA,ALPBORDN,ALPBOST
+ ..K ALPBOIEN,ALPBORDS,ALPBPDAT
+ .K ALPBIEN
+ K ALPBPTN
+ ;
+ ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
+ S ALPBPG=0
+ S ALPBPTN=""
+ I ALPBSORT="N" D
+ .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  S ALPBIEN=^TMP($J,ALPBPTN) D PRT
+ ;SORT BY ROOM/BED
+ I ALPBSORT="R" D
+ .S ALPBD="",ALPRM=""
+ .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D
+ ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
+ ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
+ ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
+ ..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
+ .S ALPRM1="" F  S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1=""  D
+ ..S ALPRM="" F  S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM=""  D
+ ...S ALPBD="" F  S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD=""  D
+ ....S ALPBPTN="" F  S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN=""  D
+ .....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))  D PRT
+ D DONE
+ Q
+PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
+ M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
+ I ALPBPG=0 D PAGE
+ S ALPBOCT=""
+ F  S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT=""  D
+ .S ALPBOST=""
+ .F  S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST=""  D
+ ..S ALPBORDN=""
+ ..F  S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN=""  D
+ ...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
+ ...; get and print this order's data...
+ ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
+ ...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
+ ...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
+ ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
+ ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
+ ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
+ ..K ALPBORDN
+ .K ALPBOST
+ K ALPBOCT
+ ; print footer at end of this patient's record...
+ I $Y+10>IOSL D PAGE
+ W !!
+ D FOOT^ALPBFRMU
+ ;Print a blank page between patient
+ W @IOF
+ S ALPBPG=0
+ K ALPBPDAT
+ Q
+ ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
+ ;
+DONE ;
+ K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
+ I $D(ZTQUEUED) S ZTREQ="@"
+ Q
+ ;
+PAGE ; print page header for patient...
+ W @IOF
+ S ALPBPG=ALPBPG+1
+ D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
+ F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
+ K ALPBHDR,ALPBX
+ Q

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m

-              r613
+              r623
+ALPBUTL1        ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
+        ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
+        ;;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
+        ; Reference/IA
+        ; INP^VADPT/10061
+        ; DIC(42/10039
+        ; DIC(42/2440
+        ;
+ERRBLD(SEG,MSG,ERR)     ; build an error array for non-FileMan-related errors...
+        ; SEG = HL7 segment name
+        ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
+        ;       default will be used)
+        ; ERR = array passed by reference in which error will be returned
+        ; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
+        S ERR("DIERR")=1
+        S ERR("DIERR",1)=999
+        S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
+        Q
+        ;
+ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
+        ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
+        ; errors usually occur as the result of missing or bad data passed to one of the
+        ; File Manager DBS calls used by this package.
+        ;
+        ; IEN       = the patient's record number in file 53.7
+        ; OIEN      = the order number's sub-file record number in file 53.7
+        ; MSGREC    = the HL7 message's record number in file 772
+        ; SEGNAME   = the HL7 segment associated with the error (optional)
+        ; SEGDATA   = the HL7 segment's data (optional)
+        ; ERRTEXT   = an array passed by reference which contains the error
+        ;             code (numeric) and the error text to be filed.  It is
+        ;             expected that this is usually the error array returned
+        ;             from a FileMan DBS call, so the format is specific:
+        ;
+        ;             ERRTEXT("DIERR",n)=error code (numeric)
+        ;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
+        ;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
+        ;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
+        ;
+        ;             However, any error message can be passed to this module
+        ;             as long as the above format is used.
+        N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
+        S ALPBLOGD=$$NOW^XLFDT()
+        S ALPBPIEN=+$O(^ALPB(53.71,0))
+        I ALPBPIEN=0 D
+        .S X="ONE"
+        .S DIC="^ALPB(53.71,"
+        .S DIC(0)="LZ"
+        .S DIC("DR")="1///^S X=3"
+        .S DINUM=1
+        .S DLAYGO=53.71
+        .D FILE^DICN K DIC
+        .S ALPBPIEN=+Y
+        I ALPBPIEN'>0 Q
+        S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
+        S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
+        S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
+        S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
+        S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
+        S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
+        S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
+        D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
+        K ALPBFERR,ALPBFILE
+        S ALPBX=0
+        F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
+        .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
+        .; file the error code...
+        .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
+        .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
+        .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
+        .K ALPBFERR,ALPBFILE
+        .; file the error text...
+        .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
+        .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
+        .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
+        .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
+        .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
+        Q
+        ;
+CLEAN(IEN)      ; check error log records to see if the patients' whose records
+        ; are noted still exist in file 53.7.  if not, delete the error log
+        ; record(s) in file 53.71...
+        ; IEN = patient record number in file 53.7
+        ; Note:  this function is also called from DELPT^ALPBUTL when a patient's
+        ; record is deleted (as a result of a discharge action) from 53.7.
+        ;
+        N ALPBX,ALPBY,DA,DIK,X,Y
+        ; patient still has record in 53.7?  if so, quit...
+        I $G(^ALPB(53.7,IEN,0))'="" Q
+        S ALPBX=0
+        F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
+        .S ALPBY=0
+        .F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
+        ..S DA=ALPBY
+        ..S DA(1)=ALPBX
+        ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
+        ..D ^DIK
+        ..K DA,DIK
+        .K ALPBY
+        K ALPBX
+        Q
+        ;
+DELERR(ERRIEN)  ; delete an error log entry from file 53.71...
+        ; ERRIEN = error log entry's internal record number
+        N ALPBPARM,DA,DIK,X,Y
+        S ALPBPARM=+$O(^ALPB(53.71,0))
+        I ALPBPARM'>0 Q
+        S DA=ERRIEN
+        S DA(1)=ALPBPARM
+        S DIK="^ALPB(53.71,"_DA(1)_",1,"
+        D ^DIK
+        Q
+        ;
+PTLIST(LTYPE,RESULTS)   ; get list of patients in file 53.7...
+        ; LTYPE   = passed = "ALL" to list all patients or
+        ;                  = <wardname> to list patients on a selected ward
+        ; RESULTS = an array passed by reference in which data will be returned
+        N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
+        I $G(LTYPE)="" S LTYPE="ALL"
+        S ALPBX=0
+        I LTYPE="ALL" D
+        .S ALPBPTN=""
+        .F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
+        ..S ALPBIEN=0
+        ..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+        ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
+        ...I ALPBDATA="" K ALPBDATA Q
+        ...S ALPBX=ALPBX+1
+        ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
+        ...K ALPBDATA
+        ..K ALPBIEN
+        .K ALPBPTN
+        I LTYPE'="ALL" D
+        .S ALPBPTN=""
+        .F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
+        ..S ALPBIEN=0
+        ..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+        ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
+        ...I ALPBDATA="" K ALPBDATA Q
+        ...S ALPBX=ALPBX+1
+        ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
+        ...K ALPBDATA
+        ..K ALPBIEN
+        .K ALPBPTN
+        Q
+        ;
+STAT(ST)        ;This will return the value of a status code for pharmacy
+        I $G(ST)="" Q ""
+        I $L($T(@ST)) G @ST
+        Q ""
+IP      Q "pending"
+CM      Q "finished/verified by pharmacist(active)"
+DC      Q "discontinued"
+RP      Q "replaced"
+HD      Q "on hold"
+ZE      Q "expired"
+ZS      Q "suspended(active)"
+ZU      Q "un-suspended(active)"
+ZX      Q "unreleased"
+ZZ      Q "renewed"
+        ;
+STAT2(CODE)     ; convert order status code for output...
+        ; this function is used primarily by the workstation software
+        ; CODE = an order status code
+        ; returns printable status code
+        I $G(CODE)="" Q "Unknown"
+        I CODE="IP"!(CODE="ZX") Q "Pending"
+        I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
+        I CODE="HD"!(CODE="ZS") Q "Hold"
+        I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
+        Q "Unknown"
+        ;
+DIV(DFN,ALPBMDT)        ;get the Division for a patient
+        I +$G(DFN)'>0 Q ""
+        N ALPBDIV,ALPWRD,VAIN,VAINDT
+        S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
+        K ALPBMDT
+        D INP^VADPT
+        S ALPWRD=$P($G(VAIN(4)),U,1)
+        Q:+ALPWRD'>0 ""
+        ;Check to see if ward is a DOMICILIARY
+        I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM"
+        S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
+        Q:+ALPBDIV'>0 ""
+        Q ALPBDIV
+        ;
+CNV(A,B,X)      ;CONVERT A STRING
+        ;This API will take a HL7 segment and convert characters
+        ;defined in the input
+        ;Example:
+        ;Single encoding characters can be converted such as ^ to ~
+        ;or multiple encoding characters can be converted such as
+        ;  |~^@/ to ^~|/@
+        ;A is the string of HL7 encoding characters to be converted
+        ;B is the string of HL7 encoding characters to be converted to
+        ;X is te message string to be converted
+        I A=""!B=""!X="" Q ""
+        F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
+        F I=1:1:$L(B) S B(I)=$E(B,I,I)
+        S J=0
+        F  S J=$O(A(J)) Q:+J'>0  D
+        . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
+        S J=0
+        F  S J=$O(A(J)) Q:+J'>0  D
+        . Q:'$D(A(J,1))!'$D(B(J))
+        . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
+        Q X
+ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+ ;
+ ; Reference/IA
+ ; INP^VADPT/10061
+ ; DIC(42/10039
+ ; DIC(42/2440
+ ;
+ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
+ ; SEG = HL7 segment name
+ ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
+ ;       default will be used)
+ ; ERR = array passed by reference in which error will be returned
+ ; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
+ S ERR("DIERR")=1
+ S ERR("DIERR",1)=999
+ S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
+ Q
+ ;
+ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
+ ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
+ ; errors usually occur as the result of missing or bad data passed to one of the
+ ; File Manager DBS calls used by this package.
+ ;
+ ; IEN       = the patient's record number in file 53.7
+ ; OIEN      = the order number's sub-file record number in file 53.7
+ ; MSGREC    = the HL7 message's record number in file 772
+ ; SEGNAME   = the HL7 segment associated with the error (optional)
+ ; SEGDATA   = the HL7 segment's data (optional)
+ ; ERRTEXT   = an array passed by reference which contains the error
+ ;             code (numeric) and the error text to be filed.  It is
+ ;             expected that this is usually the error array returned
+ ;             from a FileMan DBS call, so the format is specific:
+ ;
+ ;             ERRTEXT("DIERR",n)=error code (numeric)
+ ;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
+ ;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
+ ;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
+ ;
+ ;             However, any error message can be passed to this module
+ ;             as long as the above format is used.
+ N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
+ S ALPBLOGD=$$NOW^XLFDT()
+ S ALPBPIEN=+$O(^ALPB(53.71,0))
+ I ALPBPIEN=0 D
+ .S X="ONE"
+ .S DIC="^ALPB(53.71,"
+ .S DIC(0)="LZ"
+ .S DIC("DR")="1///^S X=3"
+ .S DINUM=1
+ .S DLAYGO=53.71
+ .D FILE^DICN K DIC
+ .S ALPBPIEN=+Y
+ I ALPBPIEN'>0 Q
+ S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
+ D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
+ K ALPBFERR,ALPBFILE
+ S ALPBX=0
+ F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
+ .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
+ .; file the error code...
+ .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
+ .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
+ .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
+ .K ALPBFERR,ALPBFILE
+ .; file the error text...
+ .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
+ .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
+ .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
+ .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
+ .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
+ Q
+ ;
+CLEAN(IEN) ; check error log records to see if the patients' whose records
+ ; are noted still exist in file 53.7.  if not, delete the error log
+ ; record(s) in file 53.71...
+ ; IEN = patient record number in file 53.7
+ ; Note:  this function is also called from DELPT^ALPBUTL when a patient's
+ ; record is deleted (as a result of a discharge action) from 53.7.
+ ;
+ N ALPBX,ALPBY,DA,DIK,X,Y
+ ; patient still has record in 53.7?  if so, quit...
+ I $G(^ALPB(53.7,IEN,0))'="" Q
+ S ALPBX=0
+ F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
+ .S ALPBY=0
+ .F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
+ ..S DA=ALPBY
+ ..S DA(1)=ALPBX
+ ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
+ ..D ^DIK
+ ..K DA,DIK
+ .K ALPBY
+ K ALPBX
+ Q
+ ;
+DELERR(ERRIEN) ; delete an error log entry from file 53.71...
+ ; ERRIEN = error log entry's internal record number
+ N ALPBPARM,DA,DIK,X,Y
+ S ALPBPARM=+$O(^ALPB(53.71,0))
+ I ALPBPARM'>0 Q
+ S DA=ERRIEN
+ S DA(1)=ALPBPARM
+ S DIK="^ALPB(53.71,"_DA(1)_",1,"
+ D ^DIK
+ Q
+ ;
+PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
+ ; LTYPE   = passed = "ALL" to list all patients or
+ ;                  = <wardname> to list patients on a selected ward
+ ; RESULTS = an array passed by reference in which data will be returned
+ N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
+ I $G(LTYPE)="" S LTYPE="ALL"
+ S ALPBX=0
+ I LTYPE="ALL" D
+ .S ALPBPTN=""
+ .F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
+ ..S ALPBIEN=0
+ ..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+ ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
+ ...I ALPBDATA="" K ALPBDATA Q
+ ...S ALPBX=ALPBX+1
+ ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
+ ...K ALPBDATA
+ ..K ALPBIEN
+ .K ALPBPTN
+ I LTYPE'="ALL" D
+ .S ALPBPTN=""
+ .F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
+ ..S ALPBIEN=0
+ ..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+ ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
+ ...I ALPBDATA="" K ALPBDATA Q
+ ...S ALPBX=ALPBX+1
+ ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
+ ...K ALPBDATA
+ ..K ALPBIEN
+ .K ALPBPTN
+ Q
+ ;
+STAT(ST) ;This will return the value of a status code for pharmacy
+ I $G(ST)="" Q ""
+ I $L($T(@ST)) G @ST
+ Q ""
+IP Q "pending"
+CM Q "finished/verified by pharmacist(active)"
+DC Q "discontinued"
+RP Q "replaced"
+HD Q "on hold"
+ZE Q "expired"
+ZS Q "suspended(active)"
+ZU Q "un-suspended(active)"
+ZX Q "unreleased"
+ZZ Q "renewed"
+ ;
+STAT2(CODE) ; convert order status code for output...
+ ; this function is used primarily by the workstation software
+ ; CODE = an order status code
+ ; returns printable status code
+ I $G(CODE)="" Q "Unknown"
+ I CODE="IP"!(CODE="ZX") Q "Pending"
+ I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
+ I CODE="HD"!(CODE="ZS") Q "Hold"
+ I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
+ Q "Unknown"
+ ;
+DIV(DFN,ALPBMDT) ;get the Division for a patient
+ I +$G(DFN)'>0 Q ""
+ N ALPBDIV,ALPWRD,VAIN,VAINDT
+ S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
+ K ALPBMDT
+ D INP^VADPT
+ S ALPWRD=$P($G(VAIN(4)),U,1)
+ Q:+ALPWRD'>0 ""
+ ;Check to see if ward is a DOMICILIARY
+ I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM"
+ S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
+ Q:+ALPBDIV'>0 ""
+ Q ALPBDIV
+ ;
+CNV(A,B,X) ;CONVERT A STRING
+ ;This API will take a HL7 segment and convert characters
+ ;defined in the input
+ ;Example:
+ ;Single encoding characters can be converted such as ^ to ~
+ ;or multiple encoding characters can be converted such as
+ ;  |~^@/ to ^~|/@
+ ;A is the string of HL7 encoding characters to be converted
+ ;B is the string of HL7 encoding characters to be converted to
+ ;X is te message string to be converted
+ I A=""!B=""!X="" Q ""
+ F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
+ F I=1:1:$L(B) S B(I)=$E(B,I,I)
+ S J=0
+ F  S J=$O(A(J)) Q:+J'>0  D
+ . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
+ S J=0
+ F  S J=$O(A(J)) Q:+J'>0  D
+ . Q:'$D(A(J,1))!'$D(B(J))
+ . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
+ Q X

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m

-              r613
+              r623
 PSBO    ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
         ;;3.0;BAR CODE MED ADMIN;**13,32,2**;Mar 2004;Build 22
         ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
         ; Reference/IA
         ; ^DPT(/10035
         ; WARD^NURSUT5/3052
         ; EN^PSJBCMA/2828
         ; ^ORD(101.24/3429
         ; ^PSDRUG(/221
 RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST)      ;
+        ;
         ; RPC: PSB REPORT
+        ;
         ; Description:
         ; Used by the client to create individual patient extracts of
         ; CHUI report options to display on the client.
+        ;
         S RESULTS=$NAME(^TMP("PSBO",$J))
         N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
         K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
         S DFN=PSBDFN
         D NEW^PSBO1(.PSBRPT,PSBTYPE)
         I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
         S PSBIENS=+PSBRPT(0)_","
         S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
         S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
         D:$G(PSBDEV)]""
         .D NOW^%DTC
         .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
         .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
         D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
         S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
         D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
         I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
         D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
         D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
         D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
         D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
         D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
         D:$G(PSBINCL)]""
         .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
         D:$G(PSBFUTR)]""
         .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
         .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
         D FILE^DIE("","PSBFDA")
         I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
         I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
         D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q
         U IO D DQ(+PSBIENS)
         D HFSCLOSE^PSBUTL("RPC")
         S RESULTS=$NAME(^TMP("PSBO",$J))
         D:$G(PSBDEV)]"" PRINT^PSBO1
+        Q
+        ;
 XQ(PSBTYPE)     ; Called via Kernel Menus
         N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
         D NEW^PSBO1(.PSBRPT,PSBTYPE)
         I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
         S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
         W @IOF
         I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
         D:PSBSAVE
         .;Check Drug to Patient Relationship.
         .I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK  I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
         .;
         .;Allow "'BROWSER" Device
         .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
         ..S IOP="`"_IOP,%ZIS="N"
         ..D ^%ZIS
         ..I IO=IO(0) S PSBSIO=1
         ..D HOME^%ZIS K IOP
         .I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
         .W @IOF,"Submitting Your Report Request to Taskman..."
         .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
         .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
         .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
         .S ZTRTN="DQ^PSBO("_DA_")"
         .D ^%ZTLOAD
         .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
         K ^TMP("PSBO",$J)
+        Q
+        ;
 DQ(PSBRPT)      ; Dequeue report from Taskman
         N PSBWRD,PSBDFN
         Q:'$D(^PSB(53.69,PSBRPT,0))  ; No Such Report
         S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
         D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
         K ^TMP("PSBO",$J)
         S ZTREQ="@"
+        Q
+        ;
 IOM()   ; Returns good margin or not
         Q:IOM'<132 1
         W !,"**************************************************************"
         W !,"* SORRY, Your selected DEVICE does not print 132 columns.    *"
         W !,"**************************************************************"
         W !
         Q 0
+        ;
 VAL(PSBFLDS)    ; Validate that fields in PSBFLDS are filled in
         N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
         F PSB=1:1 Q:$P(PSBFLDS,";",PSB)=""  S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
         I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
         S PSB=""  F  S PSB=$O(PSBFLD(PSB)) Q:PSB=""  D:PSBFLD(PSB)=""
         .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
         .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
         .S Z="  Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
         .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
         ; Check Times
         D:$G(PSBFLD(.16))
         .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
         .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
         ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42)  ;check maxdays
         ..S:PSBDAYS="" PSBDAYS=7
         ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS    ;Determine stop date
         .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
         .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  Date: Stop Date/Time is before Start Date/Time"
         .I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
         Q:'$D(PSBMSG)  ; All is well
         D MSG^DDSUTL(.PSBMSG)
         S DDSERROR=1
+        Q
+        ;
 SETUP() ; Setup parameters for the report in PSBRPT
         N PSBWRDL,PSBINDX,PSBWRDA
         K ^TMP("PSBO",$J)
         F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
         I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
         I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN  S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)=""
         D:$P(PSBRPT(.1),U,1)="W"
         .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD  D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
         .S X="" F  S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X=""   S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
         ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN  D
         ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
         ...; Determine Sort or default to Pt Name...
         ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
         ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
         ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
         ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
         ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
         Q 1
+        ;
 WRAP(X,Y,Z)        ; Quick text wrap
+        ;
         ; Input Parameters Description:
         ;  X: Left Column of display [Optional]
         ;  Y: Cols to wrap in [Optional]
         ;  Z: Text to wrap [Optional]
+        ;
         N PSB
         F  Q:'$L(Z)  D
         .W:$X>X !
         .W:$X<X ?X
         .I $L(Z)<Y W Z S Z="" Q
         .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
         .S:PSB<1 PSB=Y
         .W $E(Z,1,PSB)
         .S Z=$E(Z,PSB+1,250)
         Q ""
+        ;
 CHECK   ;Beginning of PSB*1*10
         K ^TMP("PSJ",$J)
         N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
         S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
         S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
         S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
         D EN^PSJBCMA(PSBDFN)
         F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX  D
         .K Y,PSBORD,PSBPNM,PSBNDX
         .M PSBORD=^TMP("PSJ",$J,PSBX)
         .F PSBNDX=700,850,950  D
         ..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y  D
         ...I $P($G(PSBORD(1)),U,7)'="A" Q
         ...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
         ...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
         ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
         ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
         I PSBFLAG=1 D
         .W !,"Patient is not currently on medication: ",PSBDRUG
         .K DIRUT,DIR
         .S DIR("A")="Do you want to continue"
         .S DIR(0)="Y"
         .D ^DIR
         .S PSBANS=+Y W !
+        ;
+PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
+ ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
+ ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ; Reference/IA
+ ; ^DPT(/10035
+ ; WARD^NURSUT5/3052
+ ; EN^PSJBCMA/2828
+ ; ^ORD(101.24/3429
+ ; ^PSDRUG(/221
+RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ;
+ ;
+ ; RPC: PSB REPORT
+ ;
+ ; Description:
+ ; Used by the client to create individual patient extracts of
+ ; CHUI report options to display on the client.
+ ;
+ S RESULTS=$NAME(^TMP("PSBO",$J))
+ N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
+ K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
+ S DFN=PSBDFN
+ D NEW^PSBO1(.PSBRPT,PSBTYPE)
+ I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
+ S PSBIENS=+PSBRPT(0)_","
+ S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
+ S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
+ D:$G(PSBDEV)]""
+ .D NOW^%DTC
+ .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
+ .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
+ D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
+ S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
+ D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
+ I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
+ D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
+ D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
+ D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
+ D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
+ D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
+ D:$G(PSBINCL)]""
+ .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
+ D:$G(PSBFUTR)]""
+ .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
+ .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
+ D FILE^DIE("","PSBFDA")
+ I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
+ I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
+ D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q
+ U IO D DQ(+PSBIENS)
+ D HFSCLOSE^PSBUTL("RPC")
+ S RESULTS=$NAME(^TMP("PSBO",$J))
+ D:$G(PSBDEV)]"" PRINT^PSBO1
+ Q
+ ;
+XQ(PSBTYPE) ; Called via Kernel Menus
+ N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
+ D NEW^PSBO1(.PSBRPT,PSBTYPE)
+ I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
+ S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
+ W @IOF
+ I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
+ D:PSBSAVE
+ .;Check Drug to Patient Relationship.
+ .I PSBTYPE="BL" S PSBANS="" D CHECK  I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
+ .;
+ .;Allow "'BROWSER" Device
+ .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
+ ..S IOP="`"_IOP,%ZIS="N"
+ ..D ^%ZIS
+ ..I IO=IO(0) S PSBSIO=1
+ ..D HOME^%ZIS K IOP
+ .I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
+ .W @IOF,"Submitting Your Report Request to Taskman..."
+ .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
+ .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
+ .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
+ .S ZTRTN="DQ^PSBO("_DA_")"
+ .D ^%ZTLOAD
+ .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
+ K ^TMP("PSBO",$J)
+ Q
+ ;
+DQ(PSBRPT) ; Dequeue report from Taskman
+ N PSBWRD,PSBDFN
+ Q:'$D(^PSB(53.69,PSBRPT,0))  ; No Such Report
+ S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
+ D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
+ K ^TMP("PSBO",$J)
+ S ZTREQ="@"
+ Q
+ ;
+IOM() ; Returns good margin or not
+ Q:IOM'<132 1
+ W !,"**************************************************************"
+ W !,"* SORRY, Your selected DEVICE does not print 132 columns.    *"
+ W !,"**************************************************************"
+ W !
+ Q 0
+ ;
+VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
+ N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
+ F PSB=1:1 Q:$P(PSBFLDS,";",PSB)=""  S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
+ I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
+ S PSB=""  F  S PSB=$O(PSBFLD(PSB)) Q:PSB=""  D:PSBFLD(PSB)=""
+ .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
+ .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
+ .S Z="  Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
+ .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
+ ; Check Times
+ D:$G(PSBFLD(.16))
+ .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
+ .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
+ ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42)  ;check maxdays
+ ..S:PSBDAYS="" PSBDAYS=7
+ ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS    ;Determine stop date
+ .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
+ .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  Date: Stop Date/Time is before Start Date/Time"
+ .I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
+ Q:'$D(PSBMSG)  ; All is well
+ D MSG^DDSUTL(.PSBMSG)
+ S DDSERROR=1
+ Q
+ ;
+SETUP() ; Setup parameters for the report in PSBRPT
+ N PSBWRDL,PSBINDX,PSBWRDA
+ K ^TMP("PSBO",$J)
+ F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
+ I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
+ I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN  S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)=""
+ D:$P(PSBRPT(.1),U,1)="W"
+ .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD  D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
+ .S X="" F  S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X=""   S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
+ ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN  D
+ ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
+ ...; Determine Sort or default to Pt Name...
+ ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
+ ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
+ ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
+ ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
+ ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
+ Q 1
+ ;
+WRAP(X,Y,Z)    ; Quick text wrap
+ ;
+ ; Input Parameters Description:
+ ;  X: Left Column of display [Optional]
+ ;  Y: Cols to wrap in [Optional]
+ ;  Z: Text to wrap [Optional]
+ ;
+ N PSB
+ F  Q:'$L(Z)  D
+ .W:$X>X !
+ .W:$X<X ?X
+ .I $L(Z)<Y W Z S Z="" Q
+ .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
+ .S:PSB<1 PSB=Y
+ .W $E(Z,1,PSB)
+ .S Z=$E(Z,PSB+1,250)
+ Q ""
+ ;
+CHECK ;Beginning of PSB*1*10
+ K ^TMP("PSJ",$J)
+ N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
+ S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
+ S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
+ S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
+ D EN^PSJBCMA(PSBDFN)
+ F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX  D
+ .K Y,PSBORD,PSBPNM,PSBNDX
+ .M PSBORD=^TMP("PSJ",$J,PSBX)
+ .F PSBNDX=700,850,950  D
+ ..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y  D
+ ...I $P($G(PSBORD(1)),U,7)'="A" Q
+ ...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
+ ...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
+ ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
+ ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
+ I PSBFLAG=1 D
+ .W !,"Patient is not currently on medication: ",PSBDRUG
+ .K DIRUT,DIR
+ .S DIR("A")="Do you want to continue"
+ .S DIR(0)="Y"
+ .D ^DIR
+ .S PSBANS=+Y W !
+ ;

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m

-              r613
+              r623
 PSBO1   ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
         ;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43**;Mar 2004;Build 2
         ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
         ; Reference/IA
         ; FILE^DICN/10009
+        ;
 NEW(RESULTS,PSBRTYP)    ; Create a new report request
         ; Called interactively and via RPCBroker
         K RESULTS
         ; Check Type
         I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^BZ^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
         I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
         I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
         ; Lock Log
+        L +(^PSB(53.69,0)):$S($G(DILOCKTM)>30:DILOCKTM,1:30)
         E  S RESULTS(0)="-1^Request Log Locked" Q
         ; Generate Unique Entry and Create
         F  D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))
         S DIC="^PSB(53.69,",DIC(0)="L"
         S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
         K DD,DO D FILE^DICN
         L -(^PSB(53.69,0))
         ; Okay, setup return and Boogie
         I +Y<1 S RESULTS(0)="-1^Error Creating Request"
         E  S RESULTS(0)=Y
+        Q
+        ;
 PRINT   ;
         N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
         S DA=+PSBRPT(0)
         S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
         .S IOP="`"_IOP,%ZIS="N"
         .D ^%ZIS
         .I IO=IO(0) S PSBSIO=1
         .D HOME^%ZIS K IOP
         I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q
         W @IOF,"Submitting Your Report Request to Taskman..."
         S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
         S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
         S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
         S ZTRTN="DQ^PSBO("_DA_")"
         F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
         I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
         D ^%ZTLOAD
         I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
         E  S ^TMP("PSBO",$J,1)="-1^Task Rejected."
+        Q
+        ;
 LIST(XLIST)     ;  Place List Criteria into subfile #53.692 (multiple)
         F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1)  Q:+XL1=""  D
         .I $P(XLIST(XL1),U)=PSBTYPE D
         ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
         ..S PSBIENX="+"_(XL1+1)_","_PSBIENS
         ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
         ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
+        Q
+        ;
+PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
+ ;;3.0;BAR CODE MED ADMIN;**4,13,32**;Mar 2004;Build 32
+ ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ; Reference/IA
+ ; FILE^DICN/10009
+ ;
+NEW(RESULTS,PSBRTYP) ; Create a new report request
+ ; Called interactively and via RPCBroker
+ K RESULTS
+ ; Check Type
+ I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
+ I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
+ I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
+ ; Lock Log
+ L +(^PSB(53.69,0)):0
+ E  S RESULTS(0)="-1^Request Log Locked" Q
+ ; Generate Unique Entry and Create
+ F  D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))
+ S DIC="^PSB(53.69,",DIC(0)="L"
+ S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
+ K DD,DO D FILE^DICN
+ L -(^PSB(53.69,0))
+ ; Okay, setup return and Boogie
+ I +Y<1 S RESULTS(0)="-1^Error Creating Request"
+ E  S RESULTS(0)=Y
+ Q
+ ;
+PRINT ;
+ N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
+ S DA=+PSBRPT(0)
+ S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
+ .S IOP="`"_IOP,%ZIS="N"
+ .D ^%ZIS
+ .I IO=IO(0) S PSBSIO=1
+ .D HOME^%ZIS K IOP
+ I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q
+ W @IOF,"Submitting Your Report Request to Taskman..."
+ S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
+ S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
+ S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
+ S ZTRTN="DQ^PSBO("_DA_")"
+ F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
+ I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
+ D ^%ZTLOAD
+ I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
+ E  S ^TMP("PSBO",$J,1)="-1^Task Rejected."
+ Q
+ ;
+LIST(XLIST) ;  Place List Criteria into subfile #53.692 (multiple)
+ F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1)  Q:+XL1=""  D
+ .I $P(XLIST(XL1),U)=PSBTYPE D
+ ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
+ ..S PSBIENX="+"_(XL1+1)_","_PSBIENS
+ ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
+ ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
+ Q
+ ;

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m

-              r613
+              r623
 PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM  30 Jan 2008
+        ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08;Build 4
         ;Per VHA Directive 2004-038, this routine should not be modified.
+        ;
         ;Modified from FOIA VISTA,
         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
         ;General Public License See attached copy of the License.
+        ;
         ;This program is free software; you can redistribute it and/or modify
         ;it under the terms of the GNU General Public License as published by
         ;the Free Software Foundation; either version 2 of the License, or
         ;(at your option) any later version.
+        ;
         ;This program is distributed in the hope that it will be useful,
         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
         ;GNU General Public License for more details.
+        ;
         ;You should have received a copy of the GNU General Public License along
         ;with this program; if not, write to the Free Software Foundation, Inc.,
         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+        ;
         ; Reference/IA
         ; ^DILF/2054
         ; File 200/10060
+        ;
 EN      ;
         ; Load administrations
         S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
         K PSBTSA
         F  S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP)  D
         .F  S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN  Q:'$D(^PSB(53.79,PSBIEN))  L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D  L -^PSB(53.79,PSBIEN)
         ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6)  ; Bad IEN -no evnt dt
         ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"  ;NGiven
         ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
         ..; Continuous
         ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
         ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
         ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D  D CLEAN^PSBVT Q  ;chck IV audit
         ....S PSBSIEN=PSBIEN
         ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
         ....S PSBIEN=PSBSIEN K PSBSIEN
         ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
         ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  Q:$P(PSBAUD(X),U,1)=PSBDT
         ....I X="" K PSBAUD Q
         ....I '$D(PSBAUD(X)) K PSBAUD Q
         ....S PSBS=$P(PSBAUD(X),U,3)
         ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
         ....I PSBS="NOT GIVEN" Q
         ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
         ....D PSBSTIV^PSBOMH2
         ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
         ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
         ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
         ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
         ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
         ....K PSBAUD
         ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
         ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
         ...I PSBINIT="" S PSBINIT=99
         ...;get instrc info - audt log
         ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
         ....D INSTR^PSBOMH
         ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
         ...I PSBINIT[99 S PSBINIT=""
         ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("A")
         ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("B")
         ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
         ....D DDAUD
         ....S I="" F  S I=$O(PSBTAR(I),-1) Q:I=""  I $P(PSBTAR(I),U,1)=PSBDT D
         .....S PSBS=$P(PSBTAR(I),U,3)
         .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q  ; canceled - not given
         .....I PSBS="NOT GIVEN" Q
         .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
         .....D PSBCTAR^PSBOMH2
         .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
         ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
         ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
         ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
         ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
         ...Q
         ..; 1-Time On Call or PRN
         ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
         ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
         ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
         ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
         ...I PSBINIT="" S PSBINIT=99
         ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
         ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"  D
         ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA=""  I PSBXA?1.3N  S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
         ....F S=1:1 Q:PSBM<1  S PSBM=PSBZ-S  I (PSBM>0) I (PSBT(PSBM)["GIVEN")  S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
         ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
         ....D INSTR^PSBOMH
         ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
         ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D PSBOUT(PSBDT,PSBINIT)
         ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_"            "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
         ...I PSBINIT[99 S PSBINIT=""
         ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
         ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2="  Results: <No PRN Results On File>"
         ....E  D
         .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
         .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
         .....I PSBINIT="" S PSBINIT=99
         .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
         ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
         ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
         .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D
         ......D:$D(^PSB(53.79,PSBIEN,.9,0))
         .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F  S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0  D  Q:PSBFG=1
         ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
         .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
         .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
         .....S PSBLINE2="  Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
         .....S PSBRTXTW="     Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
         .....I PSBINIT[99 S PSBINIT=""
         ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
         ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
         ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
         ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
         ...I $G(PSBLINE2)]"" D
         ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="      "_PSBRTXTW
         ....I $L(PSBLINE2)>90 D
         .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
         .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="           "_$E(PSBLINE2,91,161)
         .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="      "_PSBRTXTW
         .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="     "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)="     "_PSBRTXTW
+        Q
+        ;
 DDAUD   ;  audits for dispen drugs
+        ;
         M PSBMLA=^PSB(53.79,PSBIEN)
         S PSBGA="" I $D(PSBMLA(.9,0)) D
         .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
         ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
         ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
         ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
         ..S PSBGA=1
         .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
         ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
         ..S PSBGA=1
         I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
         S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
         .;
         .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
         .;
         .;S PSBPQRY=$Q(@PSBQRY,-1)
         .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
         .;
         .;END CHANGE
         .;
         .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
         .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment
         .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D  Q
         ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
         .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
+        Q
+        ;
 PSBOUT(PSBTET,PSBOT1)   ;
         I '$D(^PSB(53.79,PSBIEN,.9,0))  D PSBENT^PSBOMH2(PSBOT1)
         S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
         S PSBXA1=0
         F  S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0  I PSBXA1'=0  D  Q:$G(PSBOT1)["*"
         .I $L(PSBXA1)<4  D
         ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET  D
         ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
         ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct"  D
         ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
         ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
         I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
         .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
         I $G(PSBNAME)="" D
         . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
         S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
+        Q
+        ;
+PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM  30 Jan 2008
+ ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08
+ ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; Reference/IA
+ ; ^DILF/2054
+ ; File 200/10060
+ ;
+EN ;
+ ; Load administrations
+ S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
+ K PSBTSA
+ F  S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP)  D
+ .F  S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN  Q:'$D(^PSB(53.79,PSBIEN))  L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D  L -^PSB(53.79,PSBIEN)
+ ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6)  ; Bad IEN -no evnt dt
+ ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"  ;NGiven
+ ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
+ ..; Continuous
+ ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
+ ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
+ ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D  D CLEAN^PSBVT Q  ;chck IV audit
+ ....S PSBSIEN=PSBIEN
+ ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
+ ....S PSBIEN=PSBSIEN K PSBSIEN
+ ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
+ ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  Q:$P(PSBAUD(X),U,1)=PSBDT
+ ....I X="" K PSBAUD Q
+ ....I '$D(PSBAUD(X)) K PSBAUD Q
+ ....S PSBS=$P(PSBAUD(X),U,3)
+ ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
+ ....I PSBS="NOT GIVEN" Q
+ ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
+ ....D PSBSTIV^PSBOMH2
+ ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
+ ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+ ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+ ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+ ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
+ ....K PSBAUD
+ ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
+ ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
+ ...I PSBINIT="" S PSBINIT=99
+ ...;get instrc info - audt log
+ ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
+ ....D INSTR^PSBOMH
+ ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
+ ...I PSBINIT[99 S PSBINIT=""
+ ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("A")
+ ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("B")
+ ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
+ ....D DDAUD
+ ....S I="" F  S I=$O(PSBTAR(I),-1) Q:I=""  I $P(PSBTAR(I),U,1)=PSBDT D
+ .....S PSBS=$P(PSBTAR(I),U,3)
+ .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q  ; canceled - not given
+ .....I PSBS="NOT GIVEN" Q
+ .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
+ .....D PSBCTAR^PSBOMH2
+ .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
+ ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+ ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
+ ...Q
+ ..; 1-Time On Call or PRN
+ ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
+ ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
+ ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
+ ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
+ ...I PSBINIT="" S PSBINIT=99
+ ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
+ ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"  D
+ ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA=""  I PSBXA?1.3N  S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
+ ....F S=1:1 Q:PSBM<1  S PSBM=PSBZ-S  I (PSBM>0) I (PSBT(PSBM)["GIVEN")  S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
+ ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
+ ....D INSTR^PSBOMH
+ ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
+ ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D PSBOUT(PSBDT,PSBINIT)
+ ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_"            "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
+ ...I PSBINIT[99 S PSBINIT=""
+ ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
+ ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2="  Results: <No PRN Results On File>"
+ ....E  D
+ .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
+ .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
+ .....I PSBINIT="" S PSBINIT=99
+ .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
+ ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+ ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
+ .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D
+ ......D:$D(^PSB(53.79,PSBIEN,.9,0))
+ .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F  S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0  D  Q:PSBFG=1
+ ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
+ .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+ .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
+ .....S PSBLINE2="  Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
+ .....S PSBRTXTW="     Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+ .....I PSBINIT[99 S PSBINIT=""
+ ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
+ ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
+ ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
+ ...I $G(PSBLINE2)]"" D
+ ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="      "_PSBRTXTW
+ ....I $L(PSBLINE2)>90 D
+ .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
+ .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="           "_$E(PSBLINE2,91,161)
+ .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="      "_PSBRTXTW
+ .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="     "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)="     "_PSBRTXTW
+ Q
+ ;
+DDAUD ;  audits for dispen drugs
+ ;
+ M PSBMLA=^PSB(53.79,PSBIEN)
+ S PSBGA="" I $D(PSBMLA(.9,0)) D
+ .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
+ ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
+ ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
+ ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
+ ..S PSBGA=1
+ .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
+ ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
+ ..S PSBGA=1
+ I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
+ S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
+ .;
+ .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ .;
+ .;S PSBPQRY=$Q(@PSBQRY,-1)
+ .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
+ .;
+ .;END CHANGE
+ .;
+ .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
+ .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment
+ .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D  Q
+ ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
+ .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
+ Q
+ ;
+PSBOUT(PSBTET,PSBOT1) ;
+ I '$D(^PSB(53.79,PSBIEN,.9,0))  D PSBENT^PSBOMH2(PSBOT1)
+ S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+ S PSBXA1=0
+ F  S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0  I PSBXA1'=0  D  Q:$G(PSBOT1)["*"
+ .I $L(PSBXA1)<4  D
+ ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET  D
+ ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+ ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct"  D
+ ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
+ ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
+ I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
+ .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+ I $G(PSBNAME)="" D
+ . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+ S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m

-              r613
+              r623
 PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
+        ;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
+        ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+        ;
+        ; Reference/IA
         ; ^DIC(42/2440
+        ; EN^PSJBCMA2/2830
+        ; VADPT/10061
+        ;
+        ;
 EN(PSBDFN,PSBORD)       ;
+        ;
         S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
         K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
         D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
         ; get IV parameters for the current ward
         S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
+        D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
         I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D  ; if IV paramaters defined for ward use them
         .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
         .S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
         I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D  ; if IV parameters not defined for ward get defaults for division
         .D:$D(PSBWDIV)  ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
         ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
         ..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
         ..E  S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
         ..F X=2:1 Q:$P(PSBCSTR,U,X)=""  S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
         ..K PSBWDIV ; Kill temp variable.
         F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)=""  D  ; process all orders
         .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
         .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D  ; Must compare "active" orders for changes made - look beyond "pendings"
         ..F  D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P")  ;
         ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; Refresh data
         ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
         .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
         .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
         .K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1)  ; check IV parameters against activity log for this order when no "I"nvalid message
         .I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X))  S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1
         .K ^TMP("PSJ2",$J)
         .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD  ; check IV parameters against previous order when no "I"nvalid message
         .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; restore variable for this order
         .; okay - we have invalids and warnings through this order so process bags for this order
         .I '$D(PSBUIDA) Q  ; got errors and warning but no bags printed for this order - go to the next
         .S PSBUID="" F  S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID=""  D
         ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX=""  D  ; check if bag is in 53.79
         ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
         ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
         ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
         ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9)  ; add action status
         ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6)  ; add action date/time
         ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1)  ; add order ID was administered for
         ..S $P(X,U,5)=PSBONX  ; add order ID was printed for
         ..S $P(X,U,6)=PSBOSTS  ; add order status
         ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1)  ; add date/time ID was printed
         ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3)  ; add lable status from pharmacy
         ..S $P(X,U,9)=""  ; 9 open for later development
         ..S $P(X,U,10)=PSBUIDA(PSBUID)  ; add return from PSJ1
         ..D BWAR
         ..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D  S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1)
         ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
         ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
         ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
         ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
         ...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
         ...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
         ..S ^TMP("PSBAR",$J,PSBUID)=X K X
         D CLEAN^PSBVT
         K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
         K PSBADA,PSBSOLA,PSBOTMP
         I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
         D PSJ1^PSBVT(DFN,PSBORD)  ; restore variables for calling order
+        Q
+        ;
 SAVEPAR ; save parameters from current order
         K PSBOTMP
         I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E  S PSBOTMP("ADD")=""  ; additive, strength, bottle
         I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E  S PSBOTMP("SOL")=""  ; solution, volume,
         K PSBADA,PSBSOLA
         S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
         S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
         S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
         S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
         S PSBOTMP("STOP DATE/TIME")=PSBOSP
         D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1))  ; setup previous order variables
+        Q
+        ;
 CHKORD  ; check previous order against current order
         I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
         I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
         I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
         I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
         I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
         I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
         I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
         I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
         I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
         I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
         I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
+        Q
 CHKADD  ;
         N X,Y
         I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q  ; no additives
         I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order has addtives not in current order
         I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order missing additives in current order
         S X="" F  S X=$O(PSBADA(X)) Q:X=""  D  Q  ; check that additives, strength, and bottle are the same
         .I PSBADA(X)=PSBOTMP("ADD",X) Q  ; everything the same
         .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
         .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
+        Q
+        ;
 CHKSOL  ;
         N X,Y
         I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q  ; no solutions
         I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order has solutions not in current order
         I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order missing solutions in current order
         S X="" F  S X=$O(PSBSOLA(X)) Q:X=""  D  Q  ; check that solutions volume are the same
         .I PSBSOLA(X)=PSBOTMP("SOL",X) Q  ; everything the same
         .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
         .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
+        Q
+        ;
 BWAR    ;
         N X,Y,Z,PSBONX
         S X=^TMP("PSBAR",$J,"W",0)+1
         S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)=""  D  ; Display "Warning"s for changes
         .I '$D(PSBMWAR(PSBONX)) Q
         .S Y="" F  S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N  D
         ..S Z="",PSBYS="" F  S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z=""  S PSBYS=PSBYS_Z_";"
         ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
         ..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1
         .K PSBMWAR(PSBONX)
+        Q
+        ;
 MSG(PSBMVAR,PSBDATE)    ;
         I PSBMI=1 Q  ;already have an invalid don't need anymore
         F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D  Q
         .I $P(PSBIVPAR,U,Y)="W" D
         ..S PSBMVAR=$TR(PSBMVAR,"^")
         ..I PSBMW=0 S PSBMW=1
         ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
         ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
         ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
         ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
         .I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
+        Q
+PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
+ ;;3.0;BAR CODE MED ADMIN;;Mar 2004
+ ;
+ ; Reference/IA
+ ; ^DIC(42/1377
+ ; ^DIC(42/2440
+ ; EN^PSJCBMA1/2829
+ ; EN^PSJBCMA2/2830
+ ; DIQ(2/10035
+ ;
+EN(PSBDFN,PSBORD) ;
+ ;
+ S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
+ K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
+ D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
+ ; get IV parameters for the current ward
+ S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
+ S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD
+ I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D  ; if IV paramaters defined for ward use them
+ .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
+ .S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
+ I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D  ; if IV parameters not defined for ward get defaults for division
+ .D:$D(PSBWDIV)  ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
+ ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1)
+ ..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
+ ..E  S PSBWDIV="DIV.`"_PSBWDIV
+ ..F X=2:1 Q:$P(PSBCSTR,U,X)=""  S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
+ ..K PSBWDIV ; Kill temp variable.
+ F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)=""  D  ; process all orders
+ .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
+ .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D  ; Must compare "active" orders for changes made - look beyond "pendings"
+ ..F  D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P")  ;
+ ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; Refresh data
+ ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
+ .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
+ .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
+ .K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1)  ; check IV parameters against activity log for this order when no "I"nvalid message
+ .I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X))  S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1
+ .K ^TMP("PSJ2",$J)
+ .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD  ; check IV parameters against previous order when no "I"nvalid message
+ .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; restore variable for this order
+ .; okay - we have invalids and warnings through this order so process bags for this order
+ .I '$D(PSBUIDA) Q  ; got errors and warning but no bags printed for this order - go to the next
+ .S PSBUID="" F  S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID=""  D
+ ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX=""  D  ; check if bag is in 53.79
+ ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
+ ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
+ ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
+ ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9)  ; add action status
+ ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6)  ; add action date/time
+ ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1)  ; add order ID was administered for
+ ..S $P(X,U,5)=PSBONX  ; add order ID was printed for
+ ..S $P(X,U,6)=PSBOSTS  ; add order status
+ ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1)  ; add date/time ID was printed
+ ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3)  ; add lable status from pharmacy
+ ..S $P(X,U,9)=""  ; 9 open for later development
+ ..S $P(X,U,10)=PSBUIDA(PSBUID)  ; add return from PSJ1
+ ..D BWAR
+ ..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D  S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1)
+ ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
+ ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
+ ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
+ ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
+ ...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
+ ...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
+ ..S ^TMP("PSBAR",$J,PSBUID)=X K X
+ D CLEAN^PSBVT
+ K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
+ K PSBADA,PSBSOLA,PSBOTMP
+ I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
+ D PSJ1^PSBVT(DFN,PSBORD)  ; restore variables for calling order
+ Q
+ ;
+SAVEPAR ; save parameters from current order
+ K PSBOTMP
+ I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E  S PSBOTMP("ADD")=""  ; additive, strength, bottle
+ I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E  S PSBOTMP("SOL")=""  ; solution, volume,
+ K PSBADA,PSBSOLA
+ S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
+ S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
+ S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
+ S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
+ S PSBOTMP("STOP DATE/TIME")=PSBOSP
+ D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1))  ; setup previous order variables
+ Q
+ ;
+CHKORD ; check previous order against current order
+ I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
+ I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
+ I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
+ I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
+ I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
+ I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
+ I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
+ I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
+ I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
+ I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
+ I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
+ Q
+CHKADD ;
+ N X,Y
+ I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q  ; no additives
+ I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order has addtives not in current order
+ I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order missing additives in current order
+ S X="" F  S X=$O(PSBADA(X)) Q:X=""  D  Q  ; check that additives, strength, and bottle are the same
+ .I PSBADA(X)=PSBOTMP("ADD",X) Q  ; everything the same
+ .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
+ .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
+ Q
+ ;
+CHKSOL ;
+ N X,Y
+ I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q  ; no solutions
+ I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order has solutions not in current order
+ I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order missing solutions in current order
+ S X="" F  S X=$O(PSBSOLA(X)) Q:X=""  D  Q  ; check that solutions volume are the same
+ .I PSBSOLA(X)=PSBOTMP("SOL",X) Q  ; everything the same
+ .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
+ .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
+ Q
+ ;
+BWAR ;
+ N X,Y,Z,PSBONX
+ S X=^TMP("PSBAR",$J,"W",0)+1
+ S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)=""  D  ; Display "Warning"s for changes
+ .I '$D(PSBMWAR(PSBONX)) Q
+ .S Y="" F  S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N  D
+ ..S Z="",PSBYS="" F  S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z=""  S PSBYS=PSBYS_Z_";"
+ ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
+ ..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1
+ .K PSBMWAR(PSBONX)
+ Q
+ ;
+MSG(PSBMVAR,PSBDATE) ;
+ I PSBMI=1 Q  ;already have an invalid don't need anymore
+ F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D  Q
+ .I $P(PSBIVPAR,U,Y)="W" D
+ ..S PSBMVAR=$TR(PSBMVAR,"^")
+ ..I PSBMW=0 S PSBMW=1
+ ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
+ ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
+ ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
+ ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
+ .I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
+ Q

WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m

-              r613
+              r623
 PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM  30 Jan 2008
+        ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08;Build 4
         ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+        ;
         ;Modified from FOIA VISTA,
         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
         ;General Public License See attached copy of the License.
+        ;
         ;This program is free software; you can redistribute it and/or modify
         ;it under the terms of the GNU General Public License as published by
         ;the Free Software Foundation; either version 2 of the License, or
         ;(at your option) any later version.
+        ;
         ;This program is distributed in the hope that it will be useful,
         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
         ;GNU General Public License for more details.
+        ;
         ;You should have received a copy of the GNU General Public License along
         ;with this program; if not, write to the Free Software Foundation, Inc.,
         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+        ;
         ; Reference/IA
         ; File 50/221
         ; File 52.6/436
         ; File 52.7/437
         ; File 200/10060
 GETOHIST(RESULTS,DFN,PSBORD)    ;
         S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
         S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
         D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
         D EN^PSBPOIV(DFN,PSBORD)
         S PSBUID=DFN_"V"_99999 F  S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID=""  D
         .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
         .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q   ; only want the infusing bag on a dc'ed order
         .I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q  ; only want the infusing bag on an expired order
         .I $P(PSBUIDS,U,2)'="" D  Q  ; get orders from med log (53.79)
         ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
         ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
         ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
         ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
         ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
         ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
         ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
         .I $P(PSBUIDS,U,1)="I" Q  ; IV parameters say bag is invalid
         .I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q  ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
         .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
         .S PSBUIDP=$P(PSBUIDS,U,10,999)
         .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY=""  D
         ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
         ..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD=""  I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
         ..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL=""  I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
         .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
         .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
         F II=1:1 S I=$P(PSBONXS,U,II) Q:I=""  D  ; get ward stocks
         .S PSBUID="" F  S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID=""  D
         ..I PSBUID'["WS" Q  ; not a ward stock
         ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
         ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
         ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
         ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q  ; want "not completed" on DC'ed orders
         ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
         ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
         ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
         ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
         S ^TMP("PSB",$J,0)=PSB
         K ^TMP("PSBAR",$J)
+        Q
+        ;
 BAGDTL(RESULTS,PSBUID,PSBORD)   ; bag detail
         I $G(DFN)="" S DFN=+PSBUID
         S (PSBIEN,X)="" F  S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X=""  S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
         I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
         M PSBMLA=^PSB(53.79,PSBIEN)
         S X=$P(^PSB(53.79,PSBIEN,0),U,9)
         S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
         ; comments
         S PSBX="0" F  S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX=""  S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
         ; audit
         S PSBGA="" I $D(PSBMLA(.9,0)) D
         .S PSBX="0" F  S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX=""  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
         ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
         ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
         ..S PSBGA=1
         .S PSBX="0" F  S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX=""  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS"))  D
         ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
         ..S PSBGA=1
         I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
         S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
         .S PSBPQRY=$Q(@PSBQRY,-1)
         .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no previous action
         .I $QS(PSBPQRY,2)="C"  S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; previous line is a comment
         .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
         .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
         S RESULTS(0)=PSBCNT-1
         K PSBMLA,PSBIEN,PSBTMP,PSBQRY
+        Q
+        ;
 INITIAL(PSBDUZ) ;
         Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
 SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
+        ;
         ; RPC: PSB SCANMED
+        ;
         ; Description:
         ; Does a lookup on file 50 returns -1 on invalid lookup or
         ; IEN^DrugName on success
+        ;
         D NOW^%DTC S PSBDT=%
         S PSBCNT=0
         I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
         S RESULTS(PSBCNT)=1
         S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
         I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
         I PSBTAB="UDTAB" D  Q
         .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
         .I X<1 Q
         .E  S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
+        ;
         ; IV/IVPB ward stock scan
+        ;
         S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
         S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
         I $D(^PSDRUG("A527",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X=""  D
         .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
         .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
         I $D(^PSDRUG("A526",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X=""  D
         .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
         .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+        ;
         I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+        Q
+        ;
+PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM  30 Jan 2008
+ ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08
+ ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; Reference/IA
+ ; File 50/221
+ ; File 52.6/436
+ ; File 52.7/437
+ ; File 200/10060
+GETOHIST(RESULTS,DFN,PSBORD) ;
+ S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
+ S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
+ D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
+ D EN^PSBPOIV(DFN,PSBORD)
+ S PSBUID=DFN_"V"_99999 F  S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID=""  D
+ .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
+ .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q   ; only want the infusing bag on a dc'ed order
+ .I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q  ; only want the infusing bag on an expired order
+ .I $P(PSBUIDS,U,2)'="" D  Q  ; get orders from med log (53.79)
+ ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
+ ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
+ ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
+ ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
+ ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
+ .I $P(PSBUIDS,U,1)="I" Q  ; IV parameters say bag is invalid
+ .I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q  ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
+ .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
+ .S PSBUIDP=$P(PSBUIDS,U,10,999)
+ .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY=""  D
+ ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
+ ..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD=""  I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
+ ..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL=""  I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
+ .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
+ .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
+ F II=1:1 S I=$P(PSBONXS,U,II) Q:I=""  D  ; get ward stocks
+ .S PSBUID="" F  S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID=""  D
+ ..I PSBUID'["WS" Q  ; not a ward stock
+ ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
+ ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
+ ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
+ ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q  ; want "not completed" on DC'ed orders
+ ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
+ ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
+ S ^TMP("PSB",$J,0)=PSB
+ K ^TMP("PSBAR",$J)
+ Q
+ ;
+BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
+ I $G(DFN)="" S DFN=+PSBUID
+ S (PSBIEN,X)="" F  S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X=""  S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
+ I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
+ M PSBMLA=^PSB(53.79,PSBIEN)
+ S X=$P(^PSB(53.79,PSBIEN,0),U,9)
+ S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
+ ; comments
+ S PSBX="0" F  S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX=""  S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
+ ; audit
+ S PSBGA="" I $D(PSBMLA(.9,0)) D
+ .S PSBX="0" F  S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX=""  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
+ ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
+ ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
+ ..S PSBGA=1
+ .S PSBX="0" F  S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX=""  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS"))  D
+ ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
+ ..S PSBGA=1
+ I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
+ S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
+ .S PSBPQRY=$Q(@PSBQRY,-1)
+ .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no previous action
+ .I $QS(PSBPQRY,2)="C"  S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; previous line is a comment
+ .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
+ .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
+ S RESULTS(0)=PSBCNT-1
+ K PSBMLA,PSBIEN,PSBTMP,PSBQRY
+ Q
+ ;
+INITIAL(PSBDUZ) ;
+ Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
+SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
+ ;
+ ; RPC: PSB SCANMED
+ ;
+ ; Description:
+ ; Does a lookup on file 50 returns -1 on invalid lookup or
+ ; IEN^DrugName on success
+ ;
+ D NOW^%DTC S PSBDT=%
+ S PSBCNT=0
+ I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
+ S RESULTS(PSBCNT)=1
+ S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
+ I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
+ I PSBTAB="UDTAB" D  Q
+ .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
+ .I X<1 Q
+ .E  S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
+ ;
+ ; IV/IVPB ward stock scan
+ ;
+ S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
+ S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
+ I $D(^PSDRUG("A527",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X=""  D
+ .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
+ .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+ I $D(^PSDRUG("A526",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X=""  D
+ .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
+ .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+ ;
+ I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+ Q
+ ;

Note: See TracChangeset for help on using the changeset viewer.

Context Navigation

Changeset 623 for WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB

Legend:

Download in other formats: