Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 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

Legend:

Unmodified
Added
Removed
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m

    r613 r623  
    1 ALPBGEN1        ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
    2         ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         Q
    5         ;
    6 PARSIT  ;PARSE MESSAGE ON RECEIVING SIDE
    7         N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
    8         S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS=""  ;Field separator
    9         S EC=$G(HL("ECH")) Q:EC=""  ;Encoding Charaters
    10         S CS=$E(EC) ;Component separator
    11         S RS=$E(EC,2) ;Repitition separator
    12         S ESC=$E(EC,3) ;Escape character
    13         S SS=$E(EC,4) ;Subcomponent separator
    14         S EEC=ESC_"E"_ESC ;escaped escape character
    15         S EFS=ESC_"F"_ESC ;escaped field sep
    16         S ECS=ESC_"S"_ESC ;escaped component sep
    17         S ERS=ESC_"R"_ESC ; escaped repitition sep
    18         S ESS=ESC_"T"_ESC ;escaped subcomponent separator
    19         N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
    20         F  X HLNEXT Q:$G(HLQUIT)'>0  D
    21         . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
    22         . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
    23         Q
    24 PSTF    ;Process STF segment
    25         S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
    26         S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
    27         . S ALPBSSN=$TR(ALPBSSN,"-","")
    28         . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
    29         . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
    30         . ;Unescape Access Code
    31         . S ALPBAC=$$UNESC(ALPBAC)
    32         . ;Unescape Verify Code
    33         . S ALPBVC=$$UNESC(ALPBVC)
    34         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"
    35         I $D(ALERR) G PERR
    36         S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
    37         I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
    38 FILE    ;Store File 200 data on backup system
    39         N Y,DIC,DIE,DA,DR
    40         Q:'$D(ALPBNAM)
    41         Q:$L(ALPBSSN)'=9
    42         ;Try exact SSn lookup first
    43         K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
    44         ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
    45         ;If SSN lookup fails, try name lookup and add
    46         I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
    47         I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
    48         . S DIE="^VA(200,",DR="2////^S X=ALPBAC"
    49         . ;Update name too
    50         . S DR=DR_";.01////^S X=ALPBNAM"
    51         . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
    52         . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
    53         . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
    54         . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
    55         . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
    56         . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
    57         K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
    58         Q
    59 UNESC(ST,PR)    ;Unescape string from message
    60         ;ST=String to translate
    61         ;PR=Event Protocol to set up HL array variables (optional)
    62         ;First, do the escape character
    63         I $G(ST)="" Q ""
    64         S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
    65         I '$D(HL) D
    66         . S HL("FS")="^"
    67         . S HL("ECH")="~|\&"
    68         S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
    69         S EC=$G(HL("ECH")) I EC="" Q ""  ;Encoding Charaters
    70         S CS=$E(EC) ;Component separator
    71         S RS=$E(EC,2) ;Repitition separator
    72         S ESC=$E(EC,3) ;Escape character
    73         S SS=$E(EC,4) ;Subcomponent separator
    74         S EEC=ESC_"E"_ESC ;escaped escape character
    75         S EFS=ESC_"F"_ESC ;escaped field sep
    76         S ECS=ESC_"S"_ESC ;escaped component sep
    77         S ERS=ESC_"R"_ESC ; escaped repitition sep
    78         S ESS=ESC_"T"_ESC ;escaped subcomponent separator
    79         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
    80         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)
    81         I $G(L)]"" S ST=L
    82         ;
    83         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
    84         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)
    85         I $G(L)]"" S ST=L
    86         ;
    87         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
    88         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)
    89         I $G(L)]"" S ST=L
    90         ;
    91         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
    92         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)
    93         I $G(L)]"" S ST=L
    94         ;
    95         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
    96         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)
    97         I $G(L)]"" S ST=L
    98         K I,J,K,L,X
    99         Q ST
    100 PERR    ;PROCESSING ERRORS
    101         H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
    102         K ALERR
    103         Q
     1ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003  07:59
     2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
     3 Q
     4 ;
     5PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
     6 N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF
     7 S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS=""  ;Field separator
     8 S EC=$G(HL("ECH")) Q:EC=""  ;Encoding Charaters
     9 S CS=$E(EC) ;Component separator
     10 S RS=$E(EC,2) ;Repitition separator
     11 S ESC=$E(EC,3) ;Escape character
     12 S SS=$E(EC,4) ;Subcomponent separator
     13 S EEC=ESC_"E"_ESC ;escaped escape character
     14 S EFS=ESC_"F"_ESC ;escaped field sep
     15 S ECS=ESC_"S"_ESC ;escaped component sep
     16 S ERS=ESC_"R"_ESC ; escaped repitition sep
     17 S ESS=ESC_"T"_ESC ;escaped subcomponent separator
     18 N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM
     19 F  X HLNEXT Q:$G(HLQUIT)'>0  D
     20 . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2)
     21 . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF
     22 Q
     23PSTF ;Process STF segment
     24 S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA"
     25 S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D
     26 . S ALPBSSN=$TR(ALPBSSN,"-","")
     27 . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE"
     28 . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE"
     29 . ;Unescape Access Code
     30 . S ALPBAC=$$UNESC(ALPBAC)
     31 . ;Unescape Verify Code
     32 . S ALPBVC=$$UNESC(ALPBVC)
     33 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"
     34 I $D(ALERR) G PERR
     35 S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0)
     36 I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L")
     37FILE ;Store File 200 data on backup system
     38 N Y,DIC,DIE,DA,DR
     39 Q:'$D(ALPBNAM)
     40 Q:$L(ALPBSSN)'=9
     41 ;Try exact SSn lookup first
     42 K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC
     43 ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
     44 ;If SSN lookup fails, try name lookup and add
     45 I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
     46 I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
     47 . S DIE="^VA(200,",DR="2////^S X=ALPBAC"
     48 . ;Update name too
     49 . S DR=DR_";.01////^S X=ALPBNAM"
     50 . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS"
     51 . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN"
     52 . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC"
     53 . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU"
     54 . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM"
     55 . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK
     56 K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM
     57 Q
     58UNESC(ST,PR) ;Unescape string from message
     59 ;ST=String to translate
     60 ;PR=Event Protocol to set up HL array variables (optional)
     61 ;First, do the escape character
     62 I $G(ST)="" Q ""
     63 S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL)
     64 I '$D(HL) D
     65 . S HL("FS")="^"
     66 . S HL("ECH")="~|\&"
     67 S FS=$G(HL("FS")) I FS="" Q "" ;Field separator
     68 S EC=$G(HL("ECH")) I EC="" Q ""  ;Encoding Charaters
     69 S CS=$E(EC) ;Component separator
     70 S RS=$E(EC,2) ;Repitition separator
     71 S ESC=$E(EC,3) ;Escape character
     72 S SS=$E(EC,4) ;Subcomponent separator
     73 S EEC=ESC_"E"_ESC ;escaped escape character
     74 S EFS=ESC_"F"_ESC ;escaped field sep
     75 S ECS=ESC_"S"_ESC ;escaped component sep
     76 S ERS=ESC_"R"_ESC ; escaped repitition sep
     77 S ESS=ESC_"T"_ESC ;escaped subcomponent separator
     78 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
     79 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)
     80 I $G(L)]"" S ST=L
     81 ;
     82 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
     83 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)
     84 I $G(L)]"" S ST=L
     85 ;
     86 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
     87 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)
     88 I $G(L)]"" S ST=L
     89 ;
     90 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
     91 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)
     92 I $G(L)]"" S ST=L
     93 ;
     94 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
     95 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)
     96 I $G(L)]"" S ST=L
     97 K I,J,K,L,X
     98 Q ST
     99PERR ;PROCESSING ERRORS
     100 H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR
     101 K ALERR
     102 Q
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m

    r613 r623  
    1 ALPBINP ;OIFO-DALLAS/SED/KC/MW  BCMA - BCBU INPT TO HL7 ;5/2/2002
    2         ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;This routine will intercept the HL7 message that it sent from Pharmacy
    5         ;to CPRS to update order information. The message is then parsed and
    6         ;repackage so it can be sent to the BCBU workstation.
    7         ;
    8         ; Reference/IA
    9         ; EN^PSJBCBU/3876
    10         ; $$EN^VAFHLPID/263
    11         ; $$EN^VAFHAPV1/4512
    12         ; EN1^GMRADPT/10099
    13         ; EN^PSJBCMA1/2829
    14         ;
    15 IPH(MSG)        ;CAPTURE MESSAGE ARRAY FROM PHARMACY
    16         N VAIN,ALPMSG
    17         S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
    18         I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
    19         S MSH=0
    20         F  S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0  Q:$E(@ALPMSG@(MSH),1,3)="MSH"
    21         I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
    22         S MSFS=$E(@ALPMSG@(MSH),4,4)
    23         S MSCS=$E(@ALPMSG@(MSH),5,5)
    24         S MSCH=$E(@ALPMSG@(MSH),6,6)
    25         S MSCTR=$E(@ALPMSG@(MSH),4,8)
    26         ;The message is confirmed to be a Pharmacy message
    27         I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
    28         ;A PID and PV1 segment is required for this message
    29         S PID=0
    30         F  S PID=$O(@ALPMSG@(PID)) Q:PID'>0  Q:$E(@ALPMSG@(PID),1,3)="PID"
    31         I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
    32         ;Also the patient must have an inpatient status
    33         S PV1=0
    34         F  S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0  Q:$E(@ALPMSG@(PV1),1,3)="PV1"
    35         I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
    36         I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
    37         S ORC=0
    38         F  S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0  Q:$E(@ALPMSG@(ORC),1,3)="ORC"
    39         I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
    40         ;RE-BUILDING THE MESSAGE FOR BCBU
    41         S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
    42         I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
    43         S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
    44         I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
    45         K ALPB
    46         D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
    47 SEED    ;Entry point for ^ALPBIND
    48         N VAIN
    49         D INIT
    50         S SUB=0 F  S SUB=$O(ALPB(SUB)) Q:'SUB  D
    51         . ;convert and move the message to the HLA array for transport
    52         . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
    53         . ;Now check for continuations
    54         . S SUB1=0
    55         . F  S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1  D
    56         . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
    57         . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
    58         . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
    59         . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
    60         K HLA("HLS",MSH)
    61         I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
    62         S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
    63         I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
    64         S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
    65         ;Fix RXE segement for Administration Type
    66         D RXE
    67         ;Get the Division that the patient is associated with
    68         D PDIV
    69         I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
    70         I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
    71         ;SET NEW PV1
    72         D NOW^%DTC
    73         S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
    74         S HLA("HLS",PV1)=STRING
    75         I +ORC>0 D
    76         . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
    77         . Q:ALPST=""
    78         . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
    79         D AL1
    80         ;Capture message to review for testing before sending
    81         D SEND
    82 EXIT    ;EXIT and kill
    83         K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
    84         K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
    85         K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
    86         K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
    87         Q ALPRSLT
    88 INI()   ;INTIAL SET UP ENTRY
    89         G SEED
    90 INIT    ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
    91         ;SET UP ENVIRONMENT FOR MESSAGE
    92         K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
    93         S EVENT="PSB BCBU ORM SEND"
    94         D INIT^HLFNC2(EVENT,.HL,1)
    95         S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
    96         Q
    97 SEND    ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
    98         K ALPRSLT,ALPOPTS
    99         D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
    100         Q
    101 AL1     ;ALLERGY SEGMENT BUILD
    102         ;The will build the ALP segment with the curent allergies
    103         ;for the patient to be added to the message
    104         N DFN
    105         Q:+ALPDFN'>0
    106         K GMRAL
    107         S DFN=ALPDFN
    108         S GMRA="0^0^111"  ;DEFINES WHAT ALLERGIES TO RETURN
    109         D EN1^GMRADPT
    110         Q:'$D(GMRAL)
    111         S ALPI=0,ALPC=1,ALPSYM=""
    112         F  S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0  D
    113         . S ALPADR=""
    114         . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
    115         . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
    116         . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
    117         . ;S ALPII=0 F  S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0  D
    118         . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
    119         . ;S $P(ALPDATA,HLFS,6)=ALPSYM
    120         . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
    121         . S ALPC=ALPC+1
    122         K GMRAL
    123         Q
    124 RXE     ;
    125         Q:+$G(RXE)'>0
    126         K ^TMP("PSJ1",$J)
    127         Q:'$D(HLA("HLS",RXE))
    128         S DATA=HLA("HLS",RXE)
    129         D EN^PSJBCMA1(ALPDFN,ALPORD,1)
    130         S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
    131         Q:TYP="CONTINUOUS"
    132         Q:TYP="FILL ON REQUEST"
    133         S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
    134         I ALP1[TYP Q
    135         I ALP2[TYP Q
    136         S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
    137         S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
    138         S HLA("HLS",RXE)=DATA
    139         K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
    140         Q
    141 PDIV    ;PATIENT DIVISION
    142         ;Check ALPBMDT Variable
    143         S:+$G(ALPBMDT)'>0 ALPBMDT=0
    144         S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
    145         ;Screen Dom
    146         I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
    147         ;Now do I send the Message or not Based of Division
    148         I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
    149         I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
    150         Q
    151 MEDL(ALPML)     ;Use this entry to send MedLog messages
    152         N VAIN
    153         ;ALPML is the IEN of the MedLog for file #53.79
    154         I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
    155         I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
    156         ;First get the required HL7 Variables
    157         D INIT
    158         ;Need to build the PID, PV1 and ORC segments
    159         S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
    160         I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
    161         ;Get the Division that the patient is associated with
    162         D PDIV
    163         I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
    164         I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
    165         S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
    166         S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
    167         S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
    168         S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
    169         S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
    170         S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
    171         I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
    172         S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
    173         I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
    174         S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
    175         I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
    176         S HLA("HLS",1)=PID
    177         S HLA("HLS",2)=PV1
    178         ;BUILD ORC SEGMENT
    179         S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
    180         S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
    181         S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
    182         S HLA("HLS",3)=ORC
    183         ;The Message is ready to send
    184         D SEND
    185         Q ALPRSLT
    186         ;
    187 ADMQ    ;Need to que a single patient init for admissions
    188         S ALDFN=ALPDFN
    189         S ZTDTH=$$NOW^XLFDT
    190         S ZTRTN="PAT^ALPBIND"
    191         S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
    192         S ZTIO="",ZTSAVE("ALDFN")=""
    193         D ^%ZTLOAD
    194         K ZTIO,ZTDESC,ZTRTN,ZTSK
    195         Q
    196 PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT)       ;Entry Point to send patient movement
    197         N VAIN
    198         I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
    199         D INIT
    200         ;Check Movement type. If not a discharge then don't pass date and time
    201         S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
    202         ;Get the Division that the patient is associated with
    203         D PDIV
    204         I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
    205         I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
    206         S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
    207         S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
    208         S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
    209         D SEND
    210         I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
    211         I $G(ALPTT)="ADMISSION" D ADMQ
    212         ;SEND A DISCHARGE TO DIV SENDING ASIH
    213         I $G(ALPTYP)[13!($G(ALPTYP)[40) D
    214         .D INIT
    215         .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
    216         .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q  ;NO WARD
    217         .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
    218         .D GET^ALPBPARM(.HLL,ALPBDIV)
    219         .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
    220         .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
    221         .S $P(HLA("HLS",2),HLFS,37)="ASIH"
    222         .D SEND
    223         Q ALPRSLT
     1ALPBINP ;OIFO-DALLAS/SED/KC/MW  BCMA - BCBU INPT TO HL7 ;5/2/2002
     2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
     3 ;This routine will intercept the HL7 message that it sent from Pharmacy
     4 ;to CPRS to update order information. The message is then parsed and
     5 ;repackage so it can be sent to the BCBU workstation.
     6 ;
     7 ; Reference/IA
     8 ; EN^PSJBCBU/3876
     9 ; $$EN^VAFHLPID/263
     10 ; $$EN^VAFHAPV1/4512
     11 ; EN1^GMRADPT/10099
     12 ; EN^PSJBCMA1/2829
     13 ;
     14IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
     15 N VAIN,ALPMSG
     16 S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
     17 I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
     18 S MSH=0
     19 F  S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0  Q:$E(@ALPMSG@(MSH),1,3)="MSH"
     20 I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
     21 S MSFS=$E(@ALPMSG@(MSH),4,4)
     22 S MSCS=$E(@ALPMSG@(MSH),5,5)
     23 S MSCH=$E(@ALPMSG@(MSH),6,6)
     24 S MSCTR=$E(@ALPMSG@(MSH),4,8)
     25 ;The message is confirmed to be a Pharmacy message
     26 I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
     27 ;A PID and PV1 segment is required for this message
     28 S PID=0
     29 F  S PID=$O(@ALPMSG@(PID)) Q:PID'>0  Q:$E(@ALPMSG@(PID),1,3)="PID"
     30 I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
     31 ;Also the patient must have an inpatient status
     32 S PV1=0
     33 F  S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0  Q:$E(@ALPMSG@(PV1),1,3)="PV1"
     34 I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
     35 I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
     36 S ORC=0
     37 F  S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0  Q:$E(@ALPMSG@(ORC),1,3)="ORC"
     38 I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
     39 ;RE-BUILDING THE MESSAGE FOR BCBU
     40 S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
     41 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
     42 S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
     43 I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
     44 K ALPB
     45 D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
     46SEED ;Entry point for ^ALPBIND
     47 D INIT
     48 S SUB=0 F  S SUB=$O(ALPB(SUB)) Q:'SUB  D
     49 . ;convert and move the message to the HLA array for transport
     50 . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
     51 . ;Now check for continuations
     52 . S SUB1=0
     53 . F  S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1  D
     54 . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
     55 . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
     56 . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
     57 . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
     58 K HLA("HLS",MSH)
     59 I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
     60 S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
     61 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
     62 S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
     63 ;Fix RXE segement for Administration Type
     64 D RXE
     65 ;Get the Division that the patient is associated with
     66 D PDIV
     67 I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
     68 I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
     69 ;SET NEW PV1
     70 D NOW^%DTC
     71 S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
     72 S HLA("HLS",PV1)=STRING
     73 I +ORC>0 D
     74 . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
     75 . Q:ALPST=""
     76 . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
     77 D AL1
     78 ;Capture message to review for testing before sending
     79 D SEND
     80EXIT ;EXIT and kill
     81 K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
     82 K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
     83 K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
     84 K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
     85 Q ALPRSLT
     86INI() ;INTIAL SET UP ENTRY
     87 G SEED
     88INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
     89 ;SET UP ENVIRONMENT FOR MESSAGE
     90 K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
     91 S EVENT="PSB BCBU ORM SEND"
     92 D INIT^HLFNC2(EVENT,.HL,1)
     93 S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
     94 Q
     95SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
     96 K ALPRSLT,ALPOPTS
     97 D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
     98 Q
     99AL1 ;ALLERGY SEGMENT BUILD
     100 ;The will build the ALP segment with the curent allergies
     101 ;for the patient to be added to the message
     102 N DFN
     103 Q:+ALPDFN'>0
     104 K GMRAL
     105 S DFN=ALPDFN
     106 S GMRA="0^0^111"  ;DEFINES WHAT ALLERGIES TO RETURN
     107 D EN1^GMRADPT
     108 Q:'$D(GMRAL)
     109 S ALPI=0,ALPC=1,ALPSYM=""
     110 F  S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0  D
     111 . S ALPADR=""
     112 . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
     113 . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
     114 . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
     115 . ;S ALPII=0 F  S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0  D
     116 . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
     117 . ;S $P(ALPDATA,HLFS,6)=ALPSYM
     118 . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
     119 . S ALPC=ALPC+1
     120 K GMRAL
     121 Q
     122RXE ;
     123 Q:+$G(RXE)'>0
     124 K ^TMP("PSJ1",$J)
     125 Q:'$D(HLA("HLS",RXE))
     126 S DATA=HLA("HLS",RXE)
     127 D EN^PSJBCMA1(ALPDFN,ALPORD,1)
     128 S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
     129 Q:TYP="CONTINUOUS"
     130 Q:TYP="FILL ON REQUEST"
     131 S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
     132 I ALP1[TYP Q
     133 I ALP2[TYP Q
     134 S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
     135 S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
     136 S HLA("HLS",RXE)=DATA
     137 K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
     138 Q
     139PDIV ;PATIENT DIVISION
     140 ;Check ALPBMDT Variable
     141 S:+$G(ALPBMDT)'>0 ALPBMDT=0
     142 S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
     143 ;Screen Dom
     144 Q:ALPDIV="DOM"
     145 ;Now do I send the Message or not Based of Division
     146 I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
     147 I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
     148 Q
     149MEDL(ALPML) ;Use this entry to send MedLog messages
     150 N VAIN
     151 ;ALPML is the IEN of the MedLog for file #53.79
     152 I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
     153 I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
     154 ;First get the required HL7 Variables
     155 D INIT
     156 ;Need to build the PID, PV1 and ORC segments
     157 S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
     158 I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
     159 ;Get the Division that the patient is associated with
     160 D PDIV
     161 I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
     162 I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
     163 S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
     164 S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
     165 S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
     166 S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
     167 S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
     168 S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
     169 I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
     170 S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
     171 I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
     172 S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
     173 I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
     174 S HLA("HLS",1)=PID
     175 S HLA("HLS",2)=PV1
     176 ;BUILD ORC SEGMENT
     177 S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
     178 S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
     179 S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
     180 S HLA("HLS",3)=ORC
     181 ;The Message is ready to send
     182 D SEND
     183 Q ALPRSLT
     184 ;
     185ADMQ ;Need to que a single patient init for admissions
     186 S ALDFN=ALPDFN
     187 S ZTDTH=$$NOW^XLFDT
     188 S ZTRTN="PAT^ALPBIND"
     189 S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
     190 S ZTIO="",ZTSAVE("ALDFN")=""
     191 D ^%ZTLOAD
     192 K ZTIO,ZTDESC,ZTRTN,ZTSK
     193 Q
     194PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
     195 N VAIN
     196 I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
     197 D INIT
     198 ;Check Movement type. If not a discharge then don't pass date and time
     199 S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
     200 ;Get the Division that the patient is associated with
     201 D PDIV
     202 I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
     203 I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
     204 S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
     205 S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
     206 S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
     207 D SEND
     208 I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
     209 I $G(ALPTT)="ADMISSION" D ADMQ
     210 ;SEND A DISCHARGE TO DIV SENDING ASIH
     211 I $G(ALPTYP)[13!($G(ALPTYP)[40) D
     212 .D INIT
     213 .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
     214 .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q  ;NO WARD
     215 .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
     216 .D GET^ALPBPARM(.HLL,ALPBDIV)
     217 .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
     218 .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
     219 .S $P(HLA("HLS",2),HLFS,37)="ASIH"
     220 .D SEND
     221 Q ALPRSLT
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m

    r613 r623  
    1 ALPBPWRD        ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
    2         ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; NOTE: this routine is designed for hard-copy output.
    6         ;      Output is formatted for 132-column printing.
    7         ;
    8         F  D  Q:$D(DIRUT)
    9         .W !,"Inpatient Pharmacy Orders for a selected ward"
    10         .S DIR(0)="FAO^2:10"
    11         .S DIR("A")="Select WARD: "
    12         .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
    13         .D ^DIR K DIR
    14         .I $D(DIRUT) Q
    15         .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
    16         .I +$G(ALPBSEL(0))=0 D  Q
    17         ..W $C(7)
    18         ..W "  ??"
    19         ..D WARDLIST^ALPBUTL("C")
    20         ..K ALPBSEL
    21         .I +$G(ALPBSEL(0))=1 D
    22         ..S ALPBWARD=ALPBSEL(1)
    23         ..W "   ",ALPBWARD
    24         ..K ALPBSEL
    25         .I +$G(ALPBSEL(0))>1 D  I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
    26         ..S ALPBX=0
    27         ..F  S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX  W !?2,$J(ALPBX,2),"  ",ALPBSEL(ALPBX)
    28         ..K ALPBX
    29         ..S DIR(0)="NA^1:"_ALPBSEL(0)
    30         ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
    31         ..W ! D ^DIR K DIR
    32         ..I $D(DIRUT) K ALPBSEL Q
    33         ..S ALPBWARD=ALPBSEL(+Y)
    34         ..K ALPBSEL
    35         .;
    36         .; get all or just current orders?...
    37         .S DIR(0)="SA^A:ALL;C:CURRENT"
    38         .S DIR("A")="Report [A]LL or [C]URRENT orders? "
    39         .S DIR("B")="CURRENT"
    40         .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
    41         .W ! D ^DIR K DIR
    42         .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
    43         .S ALPBOTYP=Y
    44         .;
    45         .;SORT BY NAME OR ROOM/BED     added 6/23/05
    46         .S DIR(0)="SA^N:Name;R:Room/Bed"
    47         .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
    48         .S DIR("B")="Room/bed"
    49         .S DIR("?")="Sort by [N]ame or [R]oom Bed"
    50         .W ! D ^DIR K DIR
    51         .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
    52         .S ALPBSORT=Y
    53         .;
    54         .; print how many days MAR?...
    55         .S DIR(0)="NA^1:7"
    56         .S DIR("A")="Print how many days MAR? "
    57         .S DIR("B")=$$DEFDAYS^ALPBUTL()
    58         .S DIR("?")="The default is shown; you may enter 3 or 7."
    59         .W ! D ^DIR K DIR
    60         .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
    61         .S ALPBDAYS=+Y
    62         .;
    63         .; BCMA Med Log info for how many ?...
    64         .S DIR(0)="NA^1:99"
    65         .S DIR("B")=$$DEFML^ALPBUTL3()
    66         .S DIR("A")="Select how many BCMA Medication Log history: "
    67         .S DIR("A",1)=" "
    68         .S DIR("?",1)="Select a number of BCMA Medication log entries"
    69         .S DIR("?",2)="for each of the patient's orders"
    70         .S DIR("?")="They are listed by the most current entry first"
    71         .D ^DIR K DIR
    72         .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
    73         .S ALPBMLOG=Y
    74         .;
    75         .S %ZIS="Q"
    76         .S %ZIS("B")=$$DEFPRT^ALPBUTL()
    77         .I %ZIS("B")="" K %ZIS("B")
    78         .W ! D ^%ZIS K %ZIS
    79         .I POP D  Q
    80         ..W $C(7)
    81         ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
    82         .;
    83         .; output not queued...
    84         .I '$D(IO("Q")) D
    85         ..U IO
    86         ..D DQ
    87         ..I IO'=IO(0) D ^%ZISC
    88         .;
    89         .; set up the Task...
    90         .I $D(IO("Q")) D
    91         ..S ZTRTN="DQ^ALPBPWRD"
    92         ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
    93         ..S ZTSAVE("ALPBDAYS")=""
    94         ..S ZTSAVE("ALPBWARD")=""
    95         ..S ZTSAVE("ALPBMLOG")=""
    96         ..S ZTSAVE("ALPBOTYP")=""
    97         ..S ZTSAVE("ALPBSORT")=""
    98         ..S ZTIO=ION
    99         ..D ^%ZTLOAD
    100         ..D HOME^%ZIS
    101         ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
    102         ..K IO("Q"),ZTSK
    103         .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
    104         K DIRUT,DTOUT,X,Y
    105         Q
    106         ;
    107 DQ      ; output entry point...
    108         K ^TMP($J)
    109         ;
    110         ; set report date...  SED 11/4/03
    111         S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
    112         ;
    113         ; loop through ward cross reference in 53.7...
    114         S ALPBPTN=""
    115         F  S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""  D
    116         .S ALPBIEN=0
    117         .F  S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
    118         ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
    119         ..I +ALPBORDS(0)'>0 K ALPBORDS Q
    120         ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
    121         ..S ALPBOIEN=0
    122         ..F  S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN  D
    123         ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
    124         ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
    125         ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
    126         ...; if report is for "C"urrent, check stop date and quit if
    127         ...; stop date is less than report date...
    128         ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
    129         ...S ALPBORDN=ALPBORDS(ALPBOIEN)
    130         ...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
    131         ...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
    132         ...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
    133         ...K ALPBDATA,ALPBORDN,ALPBOST
    134         ..K ALPBOIEN,ALPBORDS,ALPBPDAT
    135         .K ALPBIEN
    136         K ALPBPTN
    137         ;
    138         ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
    139         S ALPBPG=0
    140         S ALPBPTN=""
    141         I ALPBSORT="N" D
    142         .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  S ALPBIEN=^TMP($J,ALPBPTN) D PRT
    143         ;SORT BY ROOM/BED
    144         I ALPBSORT="R" D
    145         .S ALPBD="",ALPRM=""
    146         .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D  Q:ALPBPTN=""
    147         ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
    148         ..I ALPBPTN="" Q  ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
    149         ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
    150         ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
    151         ..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
    152         .S ALPRM1="" F  S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1=""  D
    153         ..S ALPRM="" F  S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM=""  D
    154         ...S ALPBD="" F  S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD=""  D
    155         ....S ALPBPTN="" F  S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN=""  D
    156         .....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))  D PRT
    157         D DONE
    158         Q
    159 PRT     S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
    160         M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
    161         I ALPBPG=0 D PAGE
    162         S ALPBOCT=""
    163         F  S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT=""  D
    164         .S ALPBOST=""
    165         .F  S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST=""  D
    166         ..S ALPBORDN=""
    167         ..F  S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN=""  D
    168         ...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
    169         ...; get and print this order's data...
    170         ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
    171         ...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
    172         ...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
    173         ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
    174         ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
    175         ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
    176         ..K ALPBORDN
    177         .K ALPBOST
    178         K ALPBOCT
    179         ; print footer at end of this patient's record...
    180         I $Y+10>IOSL D PAGE
    181         W !!
    182         D FOOT^ALPBFRMU
    183         ;Print a blank page between patient
    184         W @IOF
    185         S ALPBPG=0
    186         K ALPBPDAT
    187         Q
    188         ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
    189         ;
    190 DONE    ;   
    191         K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
    192         I $D(ZTQUEUED) S ZTREQ="@"
    193         Q
    194         ;
    195 PAGE    ; print page header for patient...
    196         W @IOF
    197         S ALPBPG=ALPBPG+1
    198         D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
    199         F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
    200         K ALPBHDR,ALPBX
    201         Q
     1ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
     2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
     3 ;
     4 ; NOTE: this routine is designed for hard-copy output.
     5 ;      Output is formatted for 132-column printing.
     6 ;
     7 F  D  Q:$D(DIRUT)
     8 .W !,"Inpatient Pharmacy Orders for a selected ward"
     9 .S DIR(0)="FAO^2:10"
     10 .S DIR("A")="Select WARD: "
     11 .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")"
     12 .D ^DIR K DIR
     13 .I $D(DIRUT) Q
     14 .D WARDSEL^ALPBUTL(Y,.ALPBSEL)
     15 .I +$G(ALPBSEL(0))=0 D  Q
     16 ..W $C(7)
     17 ..W "  ??"
     18 ..D WARDLIST^ALPBUTL("C")
     19 ..K ALPBSEL
     20 .I +$G(ALPBSEL(0))=1 D
     21 ..S ALPBWARD=ALPBSEL(1)
     22 ..W "   ",ALPBWARD
     23 ..K ALPBSEL
     24 .I +$G(ALPBSEL(0))>1 D  I $D(DIRUT) K DIRUT,DTOUT,X,Y Q
     25 ..S ALPBX=0
     26 ..F  S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX  W !?2,$J(ALPBX,2),"  ",ALPBSEL(ALPBX)
     27 ..K ALPBX
     28 ..S DIR(0)="NA^1:"_ALPBSEL(0)
     29 ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): "
     30 ..W ! D ^DIR K DIR
     31 ..I $D(DIRUT) K ALPBSEL Q
     32 ..S ALPBWARD=ALPBSEL(+Y)
     33 ..K ALPBSEL
     34 .;
     35 .; get all or just current orders?...
     36 .S DIR(0)="SA^A:ALL;C:CURRENT"
     37 .S DIR("A")="Report [A]LL or [C]URRENT orders? "
     38 .S DIR("B")="CURRENT"
     39 .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired."
     40 .W ! D ^DIR K DIR
     41 .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
     42 .S ALPBOTYP=Y
     43 .;
     44 .;SORT BY NAME OR ROOM/BED     added 6/23/05
     45 .S DIR(0)="SA^N:Name;R:Room/Bed"
     46 .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? "
     47 .S DIR("B")="Room/bed"
     48 .S DIR("?")="Sort by [N]ame or [R]oom Bed"
     49 .W ! D ^DIR K DIR
     50 .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q
     51 .S ALPBSORT=Y
     52 .;
     53 .; print how many days MAR?...
     54 .S DIR(0)="NA^1:7"
     55 .S DIR("A")="Print how many days MAR? "
     56 .S DIR("B")=$$DEFDAYS^ALPBUTL()
     57 .S DIR("?")="The default is shown; you may enter 3 or 7."
     58 .W ! D ^DIR K DIR
     59 .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q
     60 .S ALPBDAYS=+Y
     61 .;
     62 .; BCMA Med Log info for how many ?...
     63 .S DIR(0)="NA^1:99"
     64 .S DIR("B")=$$DEFML^ALPBUTL3()
     65 .S DIR("A")="Select how many BCMA Medication Log history: "
     66 .S DIR("A",1)=" "
     67 .S DIR("?",1)="Select a number of BCMA Medication log entries"
     68 .S DIR("?",2)="for each of the patient's orders"
     69 .S DIR("?")="They are listed by the most current entry first"
     70 .D ^DIR K DIR
     71 .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q
     72 .S ALPBMLOG=Y
     73 .;
     74 .S %ZIS="Q"
     75 .S %ZIS("B")=$$DEFPRT^ALPBUTL()
     76 .I %ZIS("B")="" K %ZIS("B")
     77 .W ! D ^%ZIS K %ZIS
     78 .I POP D  Q
     79 ..W $C(7)
     80 ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP
     81 .;
     82 .; output not queued...
     83 .I '$D(IO("Q")) D
     84 ..U IO
     85 ..D DQ
     86 ..I IO'=IO(0) D ^%ZISC
     87 .;
     88 .; set up the Task...
     89 .I $D(IO("Q")) D
     90 ..S ZTRTN="DQ^ALPBPWRD"
     91 ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD
     92 ..S ZTSAVE("ALPBDAYS")=""
     93 ..S ZTSAVE("ALPBWARD")=""
     94 ..S ZTSAVE("ALPBMLOG")=""
     95 ..S ZTSAVE("ALPBOTYP")=""
     96 ..S ZTSAVE("ALPBSORT")=""
     97 ..S ZTIO=ION
     98 ..D ^%ZTLOAD
     99 ..D HOME^%ZIS
     100 ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!")
     101 ..K IO("Q"),ZTSK
     102 .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD
     103 K DIRUT,DTOUT,X,Y
     104 Q
     105 ;
     106DQ ; output entry point...
     107 K ^TMP($J)
     108 ;
     109 ; set report date...  SED 11/4/03
     110 S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"")
     111 ;
     112 ; loop through ward cross reference in 53.7...
     113 S ALPBPTN=""
     114 F  S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN=""  D
     115 .S ALPBIEN=0
     116 .F  S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
     117 ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS)
     118 ..I +ALPBORDS(0)'>0 K ALPBORDS Q
     119 ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
     120 ..S ALPBOIEN=0
     121 ..F  S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN  D
     122 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1))
     123 ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1)
     124 ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P"
     125 ...; if report is for "C"urrent, check stop date and quit if
     126 ...; stop date is less than report date...
     127 ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)<ALPBRDAT) K ALPBDATA Q
     128 ...S ALPBORDN=ALPBORDS(ALPBOIEN)
     129 ...S ALPBOST=$$STAT2^ALPBUTL1(ALPBORDS(ALPBOIEN,2))
     130 ...I '$D(^TMP($J,ALPBPTN)) S ^TMP($J,ALPBPTN)=ALPBIEN
     131 ...S ^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)=ALPBOIEN
     132 ...K ALPBDATA,ALPBORDN,ALPBOST
     133 ..K ALPBOIEN,ALPBORDS,ALPBPDAT
     134 .K ALPBIEN
     135 K ALPBPTN
     136 ;
     137 ; Sort by Patient Name or room/bed capability added 6/23/05 KFOX
     138 S ALPBPG=0
     139 S ALPBPTN=""
     140 I ALPBSORT="N" D
     141 .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  S ALPBIEN=^TMP($J,ALPBPTN) D PRT
     142 ;SORT BY ROOM/BED
     143 I ALPBSORT="R" D
     144 .S ALPBD="",ALPRM=""
     145 .F  S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN=""  D
     146 ..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
     147 ..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
     148 ..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
     149 ..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN
     150 .S ALPRM1="" F  S ALPRM1=$O(^TMP($J,"BCBU",ALPRM1)) Q:ALPRM1=""  D
     151 ..S ALPRM="" F  S ALPRM=$O(^TMP($J,"BCBU",ALPRM1,ALPRM)) Q:ALPRM=""  D
     152 ...S ALPBD="" F  S ALPBD=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD)) Q:ALPBD=""  D
     153 ....S ALPBPTN="" F  S ALPBPTN=$O(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN)) Q:ALPBPTN=""  D
     154 .....S ALPBIEN=$G(^TMP($J,"BCBU",ALPRM1,ALPRM,ALPBD,ALPBPTN))  D PRT
     155 D DONE
     156 Q
     157PRT S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0))
     158 M ALPBPDAT(1)=^ALPB(53.7,ALPBIEN,1)
     159 I ALPBPG=0 D PAGE
     160 S ALPBOCT=""
     161 F  S ALPBOCT=$O(^TMP($J,ALPBPTN,ALPBOCT)) Q:ALPBOCT=""  D
     162 .S ALPBOST=""
     163 .F  S ALPBOST=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST)) Q:ALPBOST=""  D
     164 ..S ALPBORDN=""
     165 ..F  S ALPBORDN=$O(^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)) Q:ALPBORDN=""  D
     166 ...S ALPBOIEN=^TMP($J,ALPBPTN,ALPBOCT,ALPBOST,ALPBORDN)
     167 ...; get and print this order's data...
     168 ...M ALPBDATA=^ALPB(53.7,ALPBIEN,2,ALPBOIEN)
     169 ...D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,ALPBMLOG,.ALPBFORM,ALPBIEN)
     170 ...;D F132^ALPBFRM1(.ALPBDATA,ALPBDAYS,.ALPBFORM)
     171 ...I $Y+ALPBFORM(0)=IOSL!($Y+ALPBFORM(0)>IOSL) D PAGE
     172 ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX)
     173 ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX
     174 ..K ALPBORDN
     175 .K ALPBOST
     176 K ALPBOCT
     177 ; print footer at end of this patient's record...
     178 I $Y+10>IOSL D PAGE
     179 W !!
     180 D FOOT^ALPBFRMU
     181 ;Print a blank page between patient
     182 W @IOF
     183 S ALPBPG=0
     184 K ALPBPDAT
     185 Q
     186 ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED
     187 ;
     188DONE ;   
     189 K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT
     190 I $D(ZTQUEUED) S ZTREQ="@"
     191 Q
     192 ;
     193PAGE ; print page header for patient...
     194 W @IOF
     195 S ALPBPG=ALPBPG+1
     196 D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR)
     197 F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX)
     198 K ALPBHDR,ALPBX
     199 Q
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m

    r613 r623  
    1 ALPBUTL1        ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
    2         ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; Reference/IA
    6         ; INP^VADPT/10061
    7         ; DIC(42/10039
    8         ; DIC(42/2440
    9         ;
    10 ERRBLD(SEG,MSG,ERR)     ; build an error array for non-FileMan-related errors...
    11         ; SEG = HL7 segment name
    12         ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
    13         ;       default will be used)
    14         ; ERR = array passed by reference in which error will be returned
    15         ; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
    16         S ERR("DIERR")=1
    17         S ERR("DIERR",1)=999
    18         S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
    19         Q
    20         ;
    21 ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
    22         ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
    23         ; errors usually occur as the result of missing or bad data passed to one of the
    24         ; File Manager DBS calls used by this package.
    25         ;
    26         ; IEN       = the patient's record number in file 53.7
    27         ; OIEN      = the order number's sub-file record number in file 53.7
    28         ; MSGREC    = the HL7 message's record number in file 772
    29         ; SEGNAME   = the HL7 segment associated with the error (optional)
    30         ; SEGDATA   = the HL7 segment's data (optional)
    31         ; ERRTEXT   = an array passed by reference which contains the error
    32         ;             code (numeric) and the error text to be filed.  It is
    33         ;             expected that this is usually the error array returned
    34         ;             from a FileMan DBS call, so the format is specific:
    35         ;
    36         ;             ERRTEXT("DIERR",n)=error code (numeric)
    37         ;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
    38         ;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
    39         ;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
    40         ;
    41         ;             However, any error message can be passed to this module
    42         ;             as long as the above format is used.
    43         N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
    44         S ALPBLOGD=$$NOW^XLFDT()
    45         S ALPBPIEN=+$O(^ALPB(53.71,0))
    46         I ALPBPIEN=0 D
    47         .S X="ONE"
    48         .S DIC="^ALPB(53.71,"
    49         .S DIC(0)="LZ"
    50         .S DIC("DR")="1///^S X=3"
    51         .S DINUM=1
    52         .S DLAYGO=53.71
    53         .D FILE^DICN K DIC
    54         .S ALPBPIEN=+Y
    55         I ALPBPIEN'>0 Q
    56         S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
    57         S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
    58         S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
    59         S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
    60         S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
    61         S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
    62         S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
    63         D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
    64         K ALPBFERR,ALPBFILE
    65         S ALPBX=0
    66         F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
    67         .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
    68         .; file the error code...
    69         .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
    70         .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
    71         .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
    72         .K ALPBFERR,ALPBFILE
    73         .; file the error text...
    74         .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
    75         .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
    76         .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
    77         .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
    78         .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
    79         Q
    80         ;
    81 CLEAN(IEN)      ; check error log records to see if the patients' whose records
    82         ; are noted still exist in file 53.7.  if not, delete the error log
    83         ; record(s) in file 53.71...
    84         ; IEN = patient record number in file 53.7
    85         ; Note:  this function is also called from DELPT^ALPBUTL when a patient's
    86         ; record is deleted (as a result of a discharge action) from 53.7.
    87         ;
    88         N ALPBX,ALPBY,DA,DIK,X,Y
    89         ; patient still has record in 53.7?  if so, quit...
    90         I $G(^ALPB(53.7,IEN,0))'="" Q
    91         S ALPBX=0
    92         F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
    93         .S ALPBY=0
    94         .F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
    95         ..S DA=ALPBY
    96         ..S DA(1)=ALPBX
    97         ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
    98         ..D ^DIK
    99         ..K DA,DIK
    100         .K ALPBY
    101         K ALPBX
    102         Q
    103         ;
    104 DELERR(ERRIEN)  ; delete an error log entry from file 53.71...
    105         ; ERRIEN = error log entry's internal record number
    106         N ALPBPARM,DA,DIK,X,Y
    107         S ALPBPARM=+$O(^ALPB(53.71,0))
    108         I ALPBPARM'>0 Q
    109         S DA=ERRIEN
    110         S DA(1)=ALPBPARM
    111         S DIK="^ALPB(53.71,"_DA(1)_",1,"
    112         D ^DIK
    113         Q
    114         ;
    115 PTLIST(LTYPE,RESULTS)   ; get list of patients in file 53.7...
    116         ; LTYPE   = passed = "ALL" to list all patients or
    117         ;                  = <wardname> to list patients on a selected ward
    118         ; RESULTS = an array passed by reference in which data will be returned
    119         N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
    120         I $G(LTYPE)="" S LTYPE="ALL"
    121         S ALPBX=0
    122         I LTYPE="ALL" D
    123         .S ALPBPTN=""
    124         .F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
    125         ..S ALPBIEN=0
    126         ..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
    127         ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
    128         ...I ALPBDATA="" K ALPBDATA Q
    129         ...S ALPBX=ALPBX+1
    130         ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
    131         ...K ALPBDATA
    132         ..K ALPBIEN
    133         .K ALPBPTN
    134         I LTYPE'="ALL" D
    135         .S ALPBPTN=""
    136         .F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
    137         ..S ALPBIEN=0
    138         ..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
    139         ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
    140         ...I ALPBDATA="" K ALPBDATA Q
    141         ...S ALPBX=ALPBX+1
    142         ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
    143         ...K ALPBDATA
    144         ..K ALPBIEN
    145         .K ALPBPTN
    146         Q
    147         ;
    148 STAT(ST)        ;This will return the value of a status code for pharmacy
    149         I $G(ST)="" Q ""
    150         I $L($T(@ST)) G @ST
    151         Q ""
    152 IP      Q "pending"
    153 CM      Q "finished/verified by pharmacist(active)"
    154 DC      Q "discontinued"
    155 RP      Q "replaced"
    156 HD      Q "on hold"
    157 ZE      Q "expired"
    158 ZS      Q "suspended(active)"
    159 ZU      Q "un-suspended(active)"
    160 ZX      Q "unreleased"
    161 ZZ      Q "renewed"
    162         ;
    163 STAT2(CODE)     ; convert order status code for output...
    164         ; this function is used primarily by the workstation software
    165         ; CODE = an order status code
    166         ; returns printable status code
    167         I $G(CODE)="" Q "Unknown"
    168         I CODE="IP"!(CODE="ZX") Q "Pending"
    169         I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
    170         I CODE="HD"!(CODE="ZS") Q "Hold"
    171         I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
    172         Q "Unknown"
    173         ;
    174 DIV(DFN,ALPBMDT)        ;get the Division for a patient
    175         I +$G(DFN)'>0 Q ""
    176         N ALPBDIV,ALPWRD,VAIN,VAINDT
    177         S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
    178         K ALPBMDT
    179         D INP^VADPT
    180         S ALPWRD=$P($G(VAIN(4)),U,1)
    181         Q:+ALPWRD'>0 ""
    182         ;Check to see if ward is a DOMICILIARY
    183         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"
    184         S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
    185         Q:+ALPBDIV'>0 ""
    186         Q ALPBDIV
    187         ;
    188 CNV(A,B,X)      ;CONVERT A STRING
    189         ;This API will take a HL7 segment and convert characters
    190         ;defined in the input
    191         ;Example:
    192         ;Single encoding characters can be converted such as ^ to ~
    193         ;or multiple encoding characters can be converted such as
    194         ;  |~^@/ to ^~|/@
    195         ;A is the string of HL7 encoding characters to be converted
    196         ;B is the string of HL7 encoding characters to be converted to
    197         ;X is te message string to be converted
    198         I A=""!B=""!X="" Q ""
    199         F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
    200         F I=1:1:$L(B) S B(I)=$E(B,I,I)
    201         S J=0
    202         F  S J=$O(A(J)) Q:+J'>0  D
    203         . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
    204         S J=0
    205         F  S J=$O(A(J)) Q:+J'>0  D
    206         . Q:'$D(A(J,1))!'$D(B(J))
    207         . 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)
    208         Q X
     1ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
     2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
     3 ;
     4 ; Reference/IA
     5 ; INP^VADPT/10061
     6 ; DIC(42/10039
     7 ; DIC(42/2440
     8 ;
     9ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
     10 ; SEG = HL7 segment name
     11 ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
     12 ;       default will be used)
     13 ; ERR = array passed by reference in which error will be returned
     14 ; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
     15 S ERR("DIERR")=1
     16 S ERR("DIERR",1)=999
     17 S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
     18 Q
     19 ;
     20ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
     21 ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
     22 ; errors usually occur as the result of missing or bad data passed to one of the
     23 ; File Manager DBS calls used by this package.
     24 ;
     25 ; IEN       = the patient's record number in file 53.7
     26 ; OIEN      = the order number's sub-file record number in file 53.7
     27 ; MSGREC    = the HL7 message's record number in file 772
     28 ; SEGNAME   = the HL7 segment associated with the error (optional)
     29 ; SEGDATA   = the HL7 segment's data (optional)
     30 ; ERRTEXT   = an array passed by reference which contains the error
     31 ;             code (numeric) and the error text to be filed.  It is
     32 ;             expected that this is usually the error array returned
     33 ;             from a FileMan DBS call, so the format is specific:
     34 ;
     35 ;             ERRTEXT("DIERR",n)=error code (numeric)
     36 ;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
     37 ;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
     38 ;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
     39 ;
     40 ;             However, any error message can be passed to this module
     41 ;             as long as the above format is used.
     42 N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
     43 S ALPBLOGD=$$NOW^XLFDT()
     44 S ALPBPIEN=+$O(^ALPB(53.71,0))
     45 I ALPBPIEN=0 D
     46 .S X="ONE"
     47 .S DIC="^ALPB(53.71,"
     48 .S DIC(0)="LZ"
     49 .S DIC("DR")="1///^S X=3"
     50 .S DINUM=1
     51 .S DLAYGO=53.71
     52 .D FILE^DICN K DIC
     53 .S ALPBPIEN=+Y
     54 I ALPBPIEN'>0 Q
     55 S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
     56 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
     57 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
     58 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
     59 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
     60 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
     61 S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
     62 D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
     63 K ALPBFERR,ALPBFILE
     64 S ALPBX=0
     65 F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
     66 .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
     67 .; file the error code...
     68 .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
     69 .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
     70 .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
     71 .K ALPBFERR,ALPBFILE
     72 .; file the error text...
     73 .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
     74 .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
     75 .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
     76 .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
     77 .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
     78 Q
     79 ;
     80CLEAN(IEN) ; check error log records to see if the patients' whose records
     81 ; are noted still exist in file 53.7.  if not, delete the error log
     82 ; record(s) in file 53.71...
     83 ; IEN = patient record number in file 53.7
     84 ; Note:  this function is also called from DELPT^ALPBUTL when a patient's
     85 ; record is deleted (as a result of a discharge action) from 53.7.
     86 ;
     87 N ALPBX,ALPBY,DA,DIK,X,Y
     88 ; patient still has record in 53.7?  if so, quit...
     89 I $G(^ALPB(53.7,IEN,0))'="" Q
     90 S ALPBX=0
     91 F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
     92 .S ALPBY=0
     93 .F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
     94 ..S DA=ALPBY
     95 ..S DA(1)=ALPBX
     96 ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
     97 ..D ^DIK
     98 ..K DA,DIK
     99 .K ALPBY
     100 K ALPBX
     101 Q
     102 ;
     103DELERR(ERRIEN) ; delete an error log entry from file 53.71...
     104 ; ERRIEN = error log entry's internal record number
     105 N ALPBPARM,DA,DIK,X,Y
     106 S ALPBPARM=+$O(^ALPB(53.71,0))
     107 I ALPBPARM'>0 Q
     108 S DA=ERRIEN
     109 S DA(1)=ALPBPARM
     110 S DIK="^ALPB(53.71,"_DA(1)_",1,"
     111 D ^DIK
     112 Q
     113 ;
     114PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
     115 ; LTYPE   = passed = "ALL" to list all patients or
     116 ;                  = <wardname> to list patients on a selected ward
     117 ; RESULTS = an array passed by reference in which data will be returned
     118 N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
     119 I $G(LTYPE)="" S LTYPE="ALL"
     120 S ALPBX=0
     121 I LTYPE="ALL" D
     122 .S ALPBPTN=""
     123 .F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
     124 ..S ALPBIEN=0
     125 ..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
     126 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
     127 ...I ALPBDATA="" K ALPBDATA Q
     128 ...S ALPBX=ALPBX+1
     129 ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
     130 ...K ALPBDATA
     131 ..K ALPBIEN
     132 .K ALPBPTN
     133 I LTYPE'="ALL" D
     134 .S ALPBPTN=""
     135 .F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
     136 ..S ALPBIEN=0
     137 ..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
     138 ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
     139 ...I ALPBDATA="" K ALPBDATA Q
     140 ...S ALPBX=ALPBX+1
     141 ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
     142 ...K ALPBDATA
     143 ..K ALPBIEN
     144 .K ALPBPTN
     145 Q
     146 ;
     147STAT(ST) ;This will return the value of a status code for pharmacy
     148 I $G(ST)="" Q ""
     149 I $L($T(@ST)) G @ST
     150 Q ""
     151IP Q "pending"
     152CM Q "finished/verified by pharmacist(active)"
     153DC Q "discontinued"
     154RP Q "replaced"
     155HD Q "on hold"
     156ZE Q "expired"
     157ZS Q "suspended(active)"
     158ZU Q "un-suspended(active)"
     159ZX Q "unreleased"
     160ZZ Q "renewed"
     161 ;
     162STAT2(CODE) ; convert order status code for output...
     163 ; this function is used primarily by the workstation software
     164 ; CODE = an order status code
     165 ; returns printable status code
     166 I $G(CODE)="" Q "Unknown"
     167 I CODE="IP"!(CODE="ZX") Q "Pending"
     168 I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
     169 I CODE="HD"!(CODE="ZS") Q "Hold"
     170 I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
     171 Q "Unknown"
     172 ;
     173DIV(DFN,ALPBMDT) ;get the Division for a patient
     174 I +$G(DFN)'>0 Q ""
     175 N ALPBDIV,ALPWRD,VAIN,VAINDT
     176 S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
     177 K ALPBMDT
     178 D INP^VADPT
     179 S ALPWRD=$P($G(VAIN(4)),U,1)
     180 Q:+ALPWRD'>0 ""
     181 ;Check to see if ward is a DOMICILIARY
     182 I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM"
     183 S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
     184 Q:+ALPBDIV'>0 ""
     185 Q ALPBDIV
     186 ;
     187CNV(A,B,X) ;CONVERT A STRING
     188 ;This API will take a HL7 segment and convert characters
     189 ;defined in the input
     190 ;Example:
     191 ;Single encoding characters can be converted such as ^ to ~
     192 ;or multiple encoding characters can be converted such as
     193 ;  |~^@/ to ^~|/@
     194 ;A is the string of HL7 encoding characters to be converted
     195 ;B is the string of HL7 encoding characters to be converted to
     196 ;X is te message string to be converted
     197 I A=""!B=""!X="" Q ""
     198 F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
     199 F I=1:1:$L(B) S B(I)=$E(B,I,I)
     200 S J=0
     201 F  S J=$O(A(J)) Q:+J'>0  D
     202 . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
     203 S J=0
     204 F  S J=$O(A(J)) Q:+J'>0  D
     205 . Q:'$D(A(J,1))!'$D(B(J))
     206 . 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)
     207 Q X
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m

    r613 r623  
    1 PSBO    ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
    2         ;;3.0;BAR CODE MED ADMIN;**13,32,2**;Mar 2004;Build 22
    3         ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
    4         ; Reference/IA
    5         ; ^DPT(/10035
    6         ; WARD^NURSUT5/3052
    7         ; EN^PSJBCMA/2828
    8         ; ^ORD(101.24/3429
    9         ; ^PSDRUG(/221
    10 RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST)      ;
    11         ;
    12         ; RPC: PSB REPORT
    13         ;
    14         ; Description:
    15         ; Used by the client to create individual patient extracts of
    16         ; CHUI report options to display on the client.
    17         ;
    18         S RESULTS=$NAME(^TMP("PSBO",$J))
    19         N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
    20         K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
    21         S DFN=PSBDFN
    22         D NEW^PSBO1(.PSBRPT,PSBTYPE)
    23         I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
    24         S PSBIENS=+PSBRPT(0)_","
    25         S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
    26         S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
    27         D:$G(PSBDEV)]""
    28         .D NOW^%DTC
    29         .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
    30         .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
    31         .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
    32         D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
    33         S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
    34         D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
    35         I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
    36         D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
    37         D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
    38         D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
    39         D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
    40         D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
    41         D:$G(PSBINCL)]""
    42         .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
    43         .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
    44         .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
    45         .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
    46         .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
    47         .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
    48         D:$G(PSBFUTR)]""
    49         .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
    50         .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
    51         .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
    52         .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
    53         .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
    54         D FILE^DIE("","PSBFDA")
    55         I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
    56         I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
    57         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
    58         U IO D DQ(+PSBIENS)
    59         D HFSCLOSE^PSBUTL("RPC")
    60         S RESULTS=$NAME(^TMP("PSBO",$J))
    61         D:$G(PSBDEV)]"" PRINT^PSBO1
    62         Q
    63         ;
    64 XQ(PSBTYPE)     ; Called via Kernel Menus
    65         N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
    66         D NEW^PSBO1(.PSBRPT,PSBTYPE)
    67         I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
    68         S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
    69         W @IOF
    70         I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
    71         D:PSBSAVE
    72         .;Check Drug to Patient Relationship.
    73         .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
    74         .;
    75         .;Allow "'BROWSER" Device
    76         .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
    77         ..S IOP="`"_IOP,%ZIS="N"
    78         ..D ^%ZIS
    79         ..I IO=IO(0) S PSBSIO=1
    80         ..D HOME^%ZIS K IOP
    81         .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
    82         .W @IOF,"Submitting Your Report Request to Taskman..."
    83         .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
    84         .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
    85         .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
    86         .S ZTRTN="DQ^PSBO("_DA_")"
    87         .D ^%ZTLOAD
    88         .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
    89         K ^TMP("PSBO",$J)
    90         Q
    91         ;
    92 DQ(PSBRPT)      ; Dequeue report from Taskman
    93         N PSBWRD,PSBDFN
    94         Q:'$D(^PSB(53.69,PSBRPT,0))  ; No Such Report
    95         S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
    96         D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
    97         K ^TMP("PSBO",$J)
    98         S ZTREQ="@"
    99         Q
    100         ;
    101 IOM()   ; Returns good margin or not
    102         Q:IOM'<132 1
    103         W !,"**************************************************************"
    104         W !,"* SORRY, Your selected DEVICE does not print 132 columns.    *"
    105         W !,"**************************************************************"
    106         W !
    107         Q 0
    108         ;
    109 VAL(PSBFLDS)    ; Validate that fields in PSBFLDS are filled in
    110         N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
    111         F PSB=1:1 Q:$P(PSBFLDS,";",PSB)=""  S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
    112         I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
    113         S PSB=""  F  S PSB=$O(PSBFLD(PSB)) Q:PSB=""  D:PSBFLD(PSB)=""
    114         .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
    115         .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
    116         .S Z="  Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
    117         .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
    118         ; Check Times
    119         D:$G(PSBFLD(.16))
    120         .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
    121         .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
    122         ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42)  ;check maxdays
    123         ..S:PSBDAYS="" PSBDAYS=7
    124         ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS    ;Determine stop date
    125         .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
    126         .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  Date: Stop Date/Time is before Start Date/Time"
    127         .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"
    128         Q:'$D(PSBMSG)  ; All is well
    129         D MSG^DDSUTL(.PSBMSG)
    130         S DDSERROR=1
    131         Q
    132         ;
    133 SETUP() ; Setup parameters for the report in PSBRPT
    134         N PSBWRDL,PSBINDX,PSBWRDA
    135         K ^TMP("PSBO",$J)
    136         F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
    137         I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
    138         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)=""
    139         D:$P(PSBRPT(.1),U,1)="W"
    140         .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD  D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
    141         .S X="" F  S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X=""   S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
    142         ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN  D
    143         ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
    144         ...; Determine Sort or default to Pt Name...
    145         ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
    146         ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
    147         ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
    148         ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
    149         ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
    150         Q 1
    151         ;
    152 WRAP(X,Y,Z)        ; Quick text wrap
    153         ;
    154         ; Input Parameters Description:
    155         ;  X: Left Column of display [Optional]
    156         ;  Y: Cols to wrap in [Optional]
    157         ;  Z: Text to wrap [Optional]
    158         ;
    159         N PSB
    160         F  Q:'$L(Z)  D
    161         .W:$X>X !
    162         .W:$X<X ?X
    163         .I $L(Z)<Y W Z S Z="" Q
    164         .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
    165         .S:PSB<1 PSB=Y
    166         .W $E(Z,1,PSB)
    167         .S Z=$E(Z,PSB+1,250)
    168         Q ""
    169         ;
    170 CHECK   ;Beginning of PSB*1*10
    171         K ^TMP("PSJ",$J)
    172         N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
    173         S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
    174         S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
    175         S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
    176         D EN^PSJBCMA(PSBDFN)
    177         F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX  D
    178         .K Y,PSBORD,PSBPNM,PSBNDX
    179         .M PSBORD=^TMP("PSJ",$J,PSBX)
    180         .F PSBNDX=700,850,950  D
    181         ..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y  D
    182         ...I $P($G(PSBORD(1)),U,7)'="A" Q
    183         ...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
    184         ...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
    185         ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
    186         ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
    187         I PSBFLAG=1 D
    188         .W !,"Patient is not currently on medication: ",PSBDRUG
    189         .K DIRUT,DIR
    190         .S DIR("A")="Do you want to continue"
    191         .S DIR(0)="Y"
    192         .D ^DIR
    193         .S PSBANS=+Y W !
    194         ;
     1PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
     2 ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
     3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
     4 ; Reference/IA
     5 ; ^DPT(/10035
     6 ; WARD^NURSUT5/3052
     7 ; EN^PSJBCMA/2828
     8 ; ^ORD(101.24/3429
     9 ; ^PSDRUG(/221
     10RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ;
     11 ;
     12 ; RPC: PSB REPORT
     13 ;
     14 ; Description:
     15 ; Used by the client to create individual patient extracts of
     16 ; CHUI report options to display on the client.
     17 ;
     18 S RESULTS=$NAME(^TMP("PSBO",$J))
     19 N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
     20 K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
     21 S DFN=PSBDFN
     22 D NEW^PSBO1(.PSBRPT,PSBTYPE)
     23 I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
     24 S PSBIENS=+PSBRPT(0)_","
     25 S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
     26 S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
     27 D:$G(PSBDEV)]""
     28 .D NOW^%DTC
     29 .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
     30 .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
     31 .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
     32 D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
     33 S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
     34 D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
     35 I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
     36 D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
     37 D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
     38 D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
     39 D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
     40 D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
     41 D:$G(PSBINCL)]""
     42 .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
     43 .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
     44 .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
     45 .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
     46 .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
     47 .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
     48 D:$G(PSBFUTR)]""
     49 .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
     50 .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
     51 .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
     52 .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
     53 .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
     54 D FILE^DIE("","PSBFDA")
     55 I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
     56 I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
     57 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
     58 U IO D DQ(+PSBIENS)
     59 D HFSCLOSE^PSBUTL("RPC")
     60 S RESULTS=$NAME(^TMP("PSBO",$J))
     61 D:$G(PSBDEV)]"" PRINT^PSBO1
     62 Q
     63 ;
     64XQ(PSBTYPE) ; Called via Kernel Menus
     65 N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
     66 D NEW^PSBO1(.PSBRPT,PSBTYPE)
     67 I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
     68 S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
     69 W @IOF
     70 I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
     71 D:PSBSAVE
     72 .;Check Drug to Patient Relationship.
     73 .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
     74 .;
     75 .;Allow "'BROWSER" Device
     76 .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
     77 ..S IOP="`"_IOP,%ZIS="N"
     78 ..D ^%ZIS
     79 ..I IO=IO(0) S PSBSIO=1
     80 ..D HOME^%ZIS K IOP
     81 .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
     82 .W @IOF,"Submitting Your Report Request to Taskman..."
     83 .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
     84 .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
     85 .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
     86 .S ZTRTN="DQ^PSBO("_DA_")"
     87 .D ^%ZTLOAD
     88 .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
     89 K ^TMP("PSBO",$J)
     90 Q
     91 ;
     92DQ(PSBRPT) ; Dequeue report from Taskman
     93 N PSBWRD,PSBDFN
     94 Q:'$D(^PSB(53.69,PSBRPT,0))  ; No Such Report
     95 S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
     96 D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
     97 K ^TMP("PSBO",$J)
     98 S ZTREQ="@"
     99 Q
     100 ;
     101IOM() ; Returns good margin or not
     102 Q:IOM'<132 1
     103 W !,"**************************************************************"
     104 W !,"* SORRY, Your selected DEVICE does not print 132 columns.    *"
     105 W !,"**************************************************************"
     106 W !
     107 Q 0
     108 ;
     109VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
     110 N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
     111 F PSB=1:1 Q:$P(PSBFLDS,";",PSB)=""  S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
     112 I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
     113 S PSB=""  F  S PSB=$O(PSBFLD(PSB)) Q:PSB=""  D:PSBFLD(PSB)=""
     114 .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
     115 .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
     116 .S Z="  Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
     117 .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
     118 ; Check Times
     119 D:$G(PSBFLD(.16))
     120 .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
     121 .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
     122 ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42)  ;check maxdays
     123 ..S:PSBDAYS="" PSBDAYS=7
     124 ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS    ;Determine stop date
     125 .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
     126 .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  Date: Stop Date/Time is before Start Date/Time"
     127 .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"
     128 Q:'$D(PSBMSG)  ; All is well
     129 D MSG^DDSUTL(.PSBMSG)
     130 S DDSERROR=1
     131 Q
     132 ;
     133SETUP() ; Setup parameters for the report in PSBRPT
     134 N PSBWRDL,PSBINDX,PSBWRDA
     135 K ^TMP("PSBO",$J)
     136 F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
     137 I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
     138 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)=""
     139 D:$P(PSBRPT(.1),U,1)="W"
     140 .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD  D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
     141 .S X="" F  S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X=""   S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
     142 ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN  D
     143 ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
     144 ...; Determine Sort or default to Pt Name...
     145 ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
     146 ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
     147 ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
     148 ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
     149 ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
     150 Q 1
     151 ;
     152WRAP(X,Y,Z)    ; Quick text wrap
     153 ;
     154 ; Input Parameters Description:
     155 ;  X: Left Column of display [Optional]
     156 ;  Y: Cols to wrap in [Optional]
     157 ;  Z: Text to wrap [Optional]
     158 ;
     159 N PSB
     160 F  Q:'$L(Z)  D
     161 .W:$X>X !
     162 .W:$X<X ?X
     163 .I $L(Z)<Y W Z S Z="" Q
     164 .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
     165 .S:PSB<1 PSB=Y
     166 .W $E(Z,1,PSB)
     167 .S Z=$E(Z,PSB+1,250)
     168 Q ""
     169 ;
     170CHECK ;Beginning of PSB*1*10
     171 K ^TMP("PSJ",$J)
     172 N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
     173 S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
     174 S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
     175 S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
     176 D EN^PSJBCMA(PSBDFN)
     177 F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX  D
     178 .K Y,PSBORD,PSBPNM,PSBNDX
     179 .M PSBORD=^TMP("PSJ",$J,PSBX)
     180 .F PSBNDX=700,850,950  D
     181 ..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y  D
     182 ...I $P($G(PSBORD(1)),U,7)'="A" Q
     183 ...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
     184 ...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
     185 ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
     186 ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
     187 I PSBFLAG=1 D
     188 .W !,"Patient is not currently on medication: ",PSBDRUG
     189 .K DIRUT,DIR
     190 .S DIR("A")="Do you want to continue"
     191 .S DIR(0)="Y"
     192 .D ^DIR
     193 .S PSBANS=+Y W !
     194 ;
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m

    r613 r623  
    1 PSBO1   ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
    2         ;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43**;Mar 2004;Build 2
    3         ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
    4         ; Reference/IA
    5         ; FILE^DICN/10009
    6         ;
    7 NEW(RESULTS,PSBRTYP)    ; Create a new report request
    8         ; Called interactively and via RPCBroker
    9         K RESULTS
    10         ; Check Type
    11         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
    12         I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
    13         I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
    14         ; Lock Log
    15         L +(^PSB(53.69,0)):$S($G(DILOCKTM)>30:DILOCKTM,1:30)
    16         E  S RESULTS(0)="-1^Request Log Locked" Q
    17         ; Generate Unique Entry and Create
    18         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))
    19         S DIC="^PSB(53.69,",DIC(0)="L"
    20         S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
    21         K DD,DO D FILE^DICN
    22         L -(^PSB(53.69,0))
    23         ; Okay, setup return and Boogie
    24         I +Y<1 S RESULTS(0)="-1^Error Creating Request"
    25         E  S RESULTS(0)=Y
    26         Q
    27         ;
    28 PRINT   ;
    29         N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
    30         S DA=+PSBRPT(0)
    31         S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
    32         .S IOP="`"_IOP,%ZIS="N"
    33         .D ^%ZIS
    34         .I IO=IO(0) S PSBSIO=1
    35         .D HOME^%ZIS K IOP
    36         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
    37         W @IOF,"Submitting Your Report Request to Taskman..."
    38         S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
    39         S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
    40         S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
    41         S ZTRTN="DQ^PSBO("_DA_")"
    42         F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
    43         I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
    44         D ^%ZTLOAD
    45         I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
    46         E  S ^TMP("PSBO",$J,1)="-1^Task Rejected."
    47         Q
    48         ;
    49 LIST(XLIST)     ;  Place List Criteria into subfile #53.692 (multiple)
    50         F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1)  Q:+XL1=""  D
    51         .I $P(XLIST(XL1),U)=PSBTYPE D
    52         ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
    53         ..S PSBIENX="+"_(XL1+1)_","_PSBIENS
    54         ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
    55         ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
    56         Q
    57         ;
     1PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
     2 ;;3.0;BAR CODE MED ADMIN;**4,13,32**;Mar 2004;Build 32
     3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
     4 ; Reference/IA
     5 ; FILE^DICN/10009
     6 ;
     7NEW(RESULTS,PSBRTYP) ; Create a new report request
     8 ; Called interactively and via RPCBroker
     9 K RESULTS
     10 ; Check Type
     11 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
     12 I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
     13 I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
     14 ; Lock Log
     15 L +(^PSB(53.69,0)):0
     16 E  S RESULTS(0)="-1^Request Log Locked" Q
     17 ; Generate Unique Entry and Create
     18 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))
     19 S DIC="^PSB(53.69,",DIC(0)="L"
     20 S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
     21 K DD,DO D FILE^DICN
     22 L -(^PSB(53.69,0))
     23 ; Okay, setup return and Boogie
     24 I +Y<1 S RESULTS(0)="-1^Error Creating Request"
     25 E  S RESULTS(0)=Y
     26 Q
     27 ;
     28PRINT ;
     29 N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
     30 S DA=+PSBRPT(0)
     31 S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
     32 .S IOP="`"_IOP,%ZIS="N"
     33 .D ^%ZIS
     34 .I IO=IO(0) S PSBSIO=1
     35 .D HOME^%ZIS K IOP
     36 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
     37 W @IOF,"Submitting Your Report Request to Taskman..."
     38 S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
     39 S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
     40 S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
     41 S ZTRTN="DQ^PSBO("_DA_")"
     42 F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
     43 I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
     44 D ^%ZTLOAD
     45 I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
     46 E  S ^TMP("PSBO",$J,1)="-1^Task Rejected."
     47 Q
     48 ;
     49LIST(XLIST) ;  Place List Criteria into subfile #53.692 (multiple)
     50 F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1)  Q:+XL1=""  D
     51 .I $P(XLIST(XL1),U)=PSBTYPE D
     52 ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
     53 ..S PSBIENX="+"_(XL1+1)_","_PSBIENS
     54 ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
     55 ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
     56 Q
     57 ;
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m

    r613 r623  
    1 PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM  30 Jan 2008
    2         ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08;Build 4
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;Modified from FOIA VISTA,
    6         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23         ; Reference/IA
    24         ; ^DILF/2054
    25         ; File 200/10060
    26         ;
    27 EN      ;
    28         ; Load administrations
    29         S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
    30         K PSBTSA
    31         F  S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP)  D
    32         .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)
    33         ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6)  ; Bad IEN -no evnt dt
    34         ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"  ;NGiven
    35         ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
    36         ..; Continuous
    37         ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
    38         ...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))
    39         ...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
    40         ....S PSBSIEN=PSBIEN
    41         ....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))
    42         ....S PSBIEN=PSBSIEN K PSBSIEN
    43         ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
    44         ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  Q:$P(PSBAUD(X),U,1)=PSBDT
    45         ....I X="" K PSBAUD Q
    46         ....I '$D(PSBAUD(X)) K PSBAUD Q
    47         ....S PSBS=$P(PSBAUD(X),U,3)
    48         ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
    49         ....I PSBS="NOT GIVEN" Q
    50         ....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")
    51         ....D PSBSTIV^PSBOMH2
    52         ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
    53         ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
    54         ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
    55         ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
    56         ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
    57         ....K PSBAUD
    58         ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
    59         ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
    60         ...I PSBINIT="" S PSBINIT=99
    61         ...;get instrc info - audt log
    62         ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
    63         ....D INSTR^PSBOMH
    64         ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
    65         ...I PSBINIT[99 S PSBINIT=""
    66         ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("A")
    67         ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("B")
    68         ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
    69         ....D DDAUD
    70         ....S I="" F  S I=$O(PSBTAR(I),-1) Q:I=""  I $P(PSBTAR(I),U,1)=PSBDT D
    71         .....S PSBS=$P(PSBTAR(I),U,3)
    72         .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q  ; canceled - not given
    73         .....I PSBS="NOT GIVEN" Q
    74         .....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")
    75         .....D PSBCTAR^PSBOMH2
    76         .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
    77         ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
    78         ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
    79         ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
    80         ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
    81         ...Q
    82         ..; 1-Time On Call or PRN
    83         ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
    84         ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
    85         ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
    86         ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
    87         ...I PSBINIT="" S PSBINIT=99
    88         ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
    89         ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"  D
    90         ....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)
    91         ....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
    92         ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
    93         ....D INSTR^PSBOMH
    94         ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
    95         ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D PSBOUT(PSBDT,PSBINIT)
    96         ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_"            "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
    97         ...I PSBINIT[99 S PSBINIT=""
    98         ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
    99         ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2="  Results: <No PRN Results On File>"
    100         ....E  D
    101         .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
    102         .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
    103         .....I PSBINIT="" S PSBINIT=99
    104         .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
    105         ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
    106         ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
    107         .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D
    108         ......D:$D(^PSB(53.79,PSBIEN,.9,0))
    109         .......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
    110         ........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))
    111         .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
    112         .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
    113         .....S PSBLINE2="  Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
    114         .....S PSBRTXTW="     Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
    115         .....I PSBINIT[99 S PSBINIT=""
    116         ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
    117         ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
    118         ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
    119         ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
    120         ...I $G(PSBLINE2)]"" D
    121         ....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
    122         ....I $L(PSBLINE2)>90 D
    123         .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
    124         .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="           "_$E(PSBLINE2,91,161)
    125         .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="      "_PSBRTXTW
    126         .....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
    127         Q
    128         ;
    129 DDAUD   ;  audits for dispen drugs
    130         ;
    131         M PSBMLA=^PSB(53.79,PSBIEN)
    132         S PSBGA="" I $D(PSBMLA(.9,0)) D
    133         .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
    134         ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
    135         ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
    136         ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
    137         ..S PSBGA=1
    138         .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
    139         ..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)
    140         ..S PSBGA=1
    141         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))
    142         S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
    143         .;
    144         .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
    145         .;
    146         .;S PSBPQRY=$Q(@PSBQRY,-1)
    147         .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
    148         .;
    149         .;END CHANGE
    150         .;
    151         .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
    152         .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment
    153         .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
    154         ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
    155         .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
    156         Q
    157         ;
    158 PSBOUT(PSBTET,PSBOT1)   ;
    159         I '$D(^PSB(53.79,PSBIEN,.9,0))  D PSBENT^PSBOMH2(PSBOT1)
    160         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)
    161         S PSBXA1=0
    162         F  S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0  I PSBXA1'=0  D  Q:$G(PSBOT1)["*"
    163         .I $L(PSBXA1)<4  D
    164         ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET  D
    165         ...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)
    166         ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct"  D
    167         ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
    168         ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
    169         I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
    170         .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
    171         I $G(PSBNAME)="" D
    172         . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
    173         S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
    174         Q
    175         ;
     1PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM  30 Jan 2008
     2 ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08
     3 ;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;Modified from FOIA VISTA,
     6 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23 ; Reference/IA
     24 ; ^DILF/2054
     25 ; File 200/10060
     26 ;
     27EN ;
     28 ; Load administrations
     29 S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
     30 K PSBTSA
     31 F  S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP)  D
     32 .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)
     33 ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6)  ; Bad IEN -no evnt dt
     34 ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"  ;NGiven
     35 ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
     36 ..; Continuous
     37 ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
     38 ...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))
     39 ...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
     40 ....S PSBSIEN=PSBIEN
     41 ....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))
     42 ....S PSBIEN=PSBSIEN K PSBSIEN
     43 ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
     44 ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  Q:$P(PSBAUD(X),U,1)=PSBDT
     45 ....I X="" K PSBAUD Q
     46 ....I '$D(PSBAUD(X)) K PSBAUD Q
     47 ....S PSBS=$P(PSBAUD(X),U,3)
     48 ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
     49 ....I PSBS="NOT GIVEN" Q
     50 ....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")
     51 ....D PSBSTIV^PSBOMH2
     52 ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
     53 ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
     54 ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
     55 ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
     56 ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
     57 ....K PSBAUD
     58 ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
     59 ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
     60 ...I PSBINIT="" S PSBINIT=99
     61 ...;get instrc info - audt log
     62 ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
     63 ....D INSTR^PSBOMH
     64 ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
     65 ...I PSBINIT[99 S PSBINIT=""
     66 ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("A")
     67 ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("B")
     68 ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
     69 ....D DDAUD
     70 ....S I="" F  S I=$O(PSBTAR(I),-1) Q:I=""  I $P(PSBTAR(I),U,1)=PSBDT D
     71 .....S PSBS=$P(PSBTAR(I),U,3)
     72 .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q  ; canceled - not given
     73 .....I PSBS="NOT GIVEN" Q
     74 .....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")
     75 .....D PSBCTAR^PSBOMH2
     76 .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
     77 ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
     78 ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
     79 ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
     80 ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
     81 ...Q
     82 ..; 1-Time On Call or PRN
     83 ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
     84 ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
     85 ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
     86 ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
     87 ...I PSBINIT="" S PSBINIT=99
     88 ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
     89 ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"  D
     90 ....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)
     91 ....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
     92 ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
     93 ....D INSTR^PSBOMH
     94 ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
     95 ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D PSBOUT(PSBDT,PSBINIT)
     96 ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_"            "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
     97 ...I PSBINIT[99 S PSBINIT=""
     98 ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
     99 ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2="  Results: <No PRN Results On File>"
     100 ....E  D
     101 .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
     102 .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
     103 .....I PSBINIT="" S PSBINIT=99
     104 .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
     105 ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
     106 ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
     107 .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D
     108 ......D:$D(^PSB(53.79,PSBIEN,.9,0))
     109 .......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
     110 ........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))
     111 .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
     112 .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
     113 .....S PSBLINE2="  Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
     114 .....S PSBRTXTW="     Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
     115 .....I PSBINIT[99 S PSBINIT=""
     116 ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
     117 ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
     118 ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
     119 ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
     120 ...I $G(PSBLINE2)]"" D
     121 ....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
     122 ....I $L(PSBLINE2)>90 D
     123 .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
     124 .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="           "_$E(PSBLINE2,91,161)
     125 .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="      "_PSBRTXTW
     126 .....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
     127 Q
     128 ;
     129DDAUD ;  audits for dispen drugs
     130 ;
     131 M PSBMLA=^PSB(53.79,PSBIEN)
     132 S PSBGA="" I $D(PSBMLA(.9,0)) D
     133 .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
     134 ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
     135 ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
     136 ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
     137 ..S PSBGA=1
     138 .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
     139 ..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)
     140 ..S PSBGA=1
     141 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))
     142 S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
     143 .;
     144 .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     145 .;
     146 .;S PSBPQRY=$Q(@PSBQRY,-1)
     147 .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
     148 .;
     149 .;END CHANGE
     150 .;
     151 .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
     152 .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment
     153 .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
     154 ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
     155 .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
     156 Q
     157 ;
     158PSBOUT(PSBTET,PSBOT1) ;
     159 I '$D(^PSB(53.79,PSBIEN,.9,0))  D PSBENT^PSBOMH2(PSBOT1)
     160 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)
     161 S PSBXA1=0
     162 F  S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0  I PSBXA1'=0  D  Q:$G(PSBOT1)["*"
     163 .I $L(PSBXA1)<4  D
     164 ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET  D
     165 ...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)
     166 ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct"  D
     167 ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
     168 ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
     169 I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
     170 .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
     171 I $G(PSBNAME)="" D
     172 . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
     173 S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)=""
     174 Q
     175 ;
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m

    r613 r623  
    1 PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
    2         ;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
    3         ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
    4         ;
    5         ; Reference/IA
    6         ; ^DIC(42/2440
    7         ; EN^PSJBCMA2/2830
    8         ; VADPT/10061
    9         ;
    10         ;
    11 EN(PSBDFN,PSBORD)       ;
    12         ;
    13         S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
    14         K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
    15         D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
    16         ; get IV parameters for the current ward
    17         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"
    18         D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
    19         I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D  ; if IV paramaters defined for ward use them
    20         .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
    21         .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)
    22         I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D  ; if IV parameters not defined for ward get defaults for division
    23         .D:$D(PSBWDIV)  ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
    24         ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
    25         ..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
    26         ..E  S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
    27         ..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)
    28         ..K PSBWDIV ; Kill temp variable.
    29         F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)=""  D  ; process all orders
    30         .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
    31         .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D  ; Must compare "active" orders for changes made - look beyond "pendings"
    32         ..F  D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P")  ;
    33         ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; Refresh data
    34         ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
    35         .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
    36         .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
    37         .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
    38         .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
    39         .K ^TMP("PSJ2",$J)
    40         .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD  ; check IV parameters against previous order when no "I"nvalid message
    41         .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; restore variable for this order
    42         .; okay - we have invalids and warnings through this order so process bags for this order
    43         .I '$D(PSBUIDA) Q  ; got errors and warning but no bags printed for this order - go to the next
    44         .S PSBUID="" F  S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID=""  D
    45         ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX=""  D  ; check if bag is in 53.79
    46         ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
    47         ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
    48         ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
    49         ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9)  ; add action status
    50         ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6)  ; add action date/time
    51         ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1)  ; add order ID was administered for
    52         ..S $P(X,U,5)=PSBONX  ; add order ID was printed for
    53         ..S $P(X,U,6)=PSBOSTS  ; add order status
    54         ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1)  ; add date/time ID was printed
    55         ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3)  ; add lable status from pharmacy
    56         ..S $P(X,U,9)=""  ; 9 open for later development
    57         ..S $P(X,U,10)=PSBUIDA(PSBUID)  ; add return from PSJ1
    58         ..D BWAR
    59         ..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)
    60         ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
    61         ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
    62         ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
    63         ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
    64         ...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
    65         ...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
    66         ..S ^TMP("PSBAR",$J,PSBUID)=X K X
    67         D CLEAN^PSBVT
    68         K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
    69         K PSBADA,PSBSOLA,PSBOTMP
    70         I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
    71         D PSJ1^PSBVT(DFN,PSBORD)  ; restore variables for calling order
    72         Q
    73         ;
    74 SAVEPAR ; save parameters from current order
    75         K PSBOTMP
    76         I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E  S PSBOTMP("ADD")=""  ; additive, strength, bottle
    77         I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E  S PSBOTMP("SOL")=""  ; solution, volume,
    78         K PSBADA,PSBSOLA
    79         S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
    80         S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
    81         S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
    82         S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
    83         S PSBOTMP("STOP DATE/TIME")=PSBOSP
    84         D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1))  ; setup previous order variables
    85         Q
    86         ;
    87 CHKORD  ; check previous order against current order
    88         I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
    89         I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
    90         I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
    91         I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
    92         I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
    93         I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
    94         I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
    95         I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
    96         I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
    97         I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
    98         I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
    99         Q
    100 CHKADD  ;
    101         N X,Y
    102         I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q  ; no additives
    103         I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order has addtives not in current order
    104         I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order missing additives in current order
    105         S X="" F  S X=$O(PSBADA(X)) Q:X=""  D  Q  ; check that additives, strength, and bottle are the same
    106         .I PSBADA(X)=PSBOTMP("ADD",X) Q  ; everything the same
    107         .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
    108         .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
    109         Q
    110         ;
    111 CHKSOL  ;
    112         N X,Y
    113         I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q  ; no solutions
    114         I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order has solutions not in current order
    115         I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order missing solutions in current order
    116         S X="" F  S X=$O(PSBSOLA(X)) Q:X=""  D  Q  ; check that solutions volume are the same
    117         .I PSBSOLA(X)=PSBOTMP("SOL",X) Q  ; everything the same
    118         .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
    119         .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
    120         Q
    121         ;
    122 BWAR    ;
    123         N X,Y,Z,PSBONX
    124         S X=^TMP("PSBAR",$J,"W",0)+1
    125         S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)=""  D  ; Display "Warning"s for changes
    126         .I '$D(PSBMWAR(PSBONX)) Q
    127         .S Y="" F  S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N  D
    128         ..S Z="",PSBYS="" F  S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z=""  S PSBYS=PSBYS_Z_";"
    129         ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
    130         ..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
    131         .K PSBMWAR(PSBONX)
    132         Q
    133         ;
    134 MSG(PSBMVAR,PSBDATE)    ;
    135         I PSBMI=1 Q  ;already have an invalid don't need anymore
    136         F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D  Q
    137         .I $P(PSBIVPAR,U,Y)="W" D
    138         ..S PSBMVAR=$TR(PSBMVAR,"^")
    139         ..I PSBMW=0 S PSBMW=1
    140         ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
    141         ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
    142         ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
    143         ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
    144         .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
    145         Q
     1PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
     2 ;;3.0;BAR CODE MED ADMIN;;Mar 2004
     3 ;
     4 ; Reference/IA
     5 ; ^DIC(42/1377
     6 ; ^DIC(42/2440
     7 ; EN^PSJCBMA1/2829
     8 ; EN^PSJBCMA2/2830
     9 ; DIQ(2/10035
     10 ;
     11EN(PSBDFN,PSBORD) ;
     12 ;
     13 S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
     14 K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
     15 D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
     16 ; get IV parameters for the current ward
     17 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"
     18 S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD
     19 I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D  ; if IV paramaters defined for ward use them
     20 .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
     21 .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)
     22 I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D  ; if IV parameters not defined for ward get defaults for division
     23 .D:$D(PSBWDIV)  ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
     24 ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1)
     25 ..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
     26 ..E  S PSBWDIV="DIV.`"_PSBWDIV
     27 ..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)
     28 ..K PSBWDIV ; Kill temp variable.
     29 F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)=""  D  ; process all orders
     30 .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
     31 .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D  ; Must compare "active" orders for changes made - look beyond "pendings"
     32 ..F  D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P")  ;
     33 ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; Refresh data
     34 ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
     35 .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
     36 .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
     37 .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
     38 .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
     39 .K ^TMP("PSJ2",$J)
     40 .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD  ; check IV parameters against previous order when no "I"nvalid message
     41 .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))  ; restore variable for this order
     42 .; okay - we have invalids and warnings through this order so process bags for this order
     43 .I '$D(PSBUIDA) Q  ; got errors and warning but no bags printed for this order - go to the next
     44 .S PSBUID="" F  S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID=""  D
     45 ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX=""  D  ; check if bag is in 53.79
     46 ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
     47 ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
     48 ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
     49 ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9)  ; add action status
     50 ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6)  ; add action date/time
     51 ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1)  ; add order ID was administered for
     52 ..S $P(X,U,5)=PSBONX  ; add order ID was printed for
     53 ..S $P(X,U,6)=PSBOSTS  ; add order status
     54 ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1)  ; add date/time ID was printed
     55 ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3)  ; add lable status from pharmacy
     56 ..S $P(X,U,9)=""  ; 9 open for later development
     57 ..S $P(X,U,10)=PSBUIDA(PSBUID)  ; add return from PSJ1
     58 ..D BWAR
     59 ..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)
     60 ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
     61 ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
     62 ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
     63 ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
     64 ...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
     65 ...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
     66 ..S ^TMP("PSBAR",$J,PSBUID)=X K X
     67 D CLEAN^PSBVT
     68 K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
     69 K PSBADA,PSBSOLA,PSBOTMP
     70 I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
     71 D PSJ1^PSBVT(DFN,PSBORD)  ; restore variables for calling order
     72 Q
     73 ;
     74SAVEPAR ; save parameters from current order
     75 K PSBOTMP
     76 I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E  S PSBOTMP("ADD")=""  ; additive, strength, bottle
     77 I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E  S PSBOTMP("SOL")=""  ; solution, volume,
     78 K PSBADA,PSBSOLA
     79 S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
     80 S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
     81 S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
     82 S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
     83 S PSBOTMP("STOP DATE/TIME")=PSBOSP
     84 D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1))  ; setup previous order variables
     85 Q
     86 ;
     87CHKORD ; check previous order against current order
     88 I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
     89 I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
     90 I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
     91 I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
     92 I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
     93 I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
     94 I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
     95 I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
     96 I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
     97 I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
     98 I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
     99 Q
     100CHKADD ;
     101 N X,Y
     102 I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q  ; no additives
     103 I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order has addtives not in current order
     104 I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q  ;previous order missing additives in current order
     105 S X="" F  S X=$O(PSBADA(X)) Q:X=""  D  Q  ; check that additives, strength, and bottle are the same
     106 .I PSBADA(X)=PSBOTMP("ADD",X) Q  ; everything the same
     107 .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
     108 .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
     109 Q
     110 ;
     111CHKSOL ;
     112 N X,Y
     113 I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q  ; no solutions
     114 I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order has solutions not in current order
     115 I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q  ;previous order missing solutions in current order
     116 S X="" F  S X=$O(PSBSOLA(X)) Q:X=""  D  Q  ; check that solutions volume are the same
     117 .I PSBSOLA(X)=PSBOTMP("SOL",X) Q  ; everything the same
     118 .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
     119 .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
     120 Q
     121 ;
     122BWAR ;
     123 N X,Y,Z,PSBONX
     124 S X=^TMP("PSBAR",$J,"W",0)+1
     125 S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)=""  D  ; Display "Warning"s for changes
     126 .I '$D(PSBMWAR(PSBONX)) Q
     127 .S Y="" F  S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N  D
     128 ..S Z="",PSBYS="" F  S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z=""  S PSBYS=PSBYS_Z_";"
     129 ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
     130 ..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
     131 .K PSBMWAR(PSBONX)
     132 Q
     133 ;
     134MSG(PSBMVAR,PSBDATE) ;
     135 I PSBMI=1 Q  ;already have an invalid don't need anymore
     136 F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D  Q
     137 .I $P(PSBIVPAR,U,Y)="W" D
     138 ..S PSBMVAR=$TR(PSBMVAR,"^")
     139 ..I PSBMW=0 S PSBMW=1
     140 ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
     141 ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
     142 ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
     143 ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
     144 .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
     145 Q
  • WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m

    r613 r623  
    1 PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM  30 Jan 2008
    2         ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08;Build 4
    3         ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
    4         ;
    5         ;Modified from FOIA VISTA,
    6         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23         ; Reference/IA
    24         ; File 50/221
    25         ; File 52.6/436
    26         ; File 52.7/437
    27         ; File 200/10060
    28 GETOHIST(RESULTS,DFN,PSBORD)    ;
    29         S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
    30         S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
    31         D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
    32         D EN^PSBPOIV(DFN,PSBORD)
    33         S PSBUID=DFN_"V"_99999 F  S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID=""  D
    34         .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
    35         .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
    36         .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
    37         .I $P(PSBUIDS,U,2)'="" D  Q  ; get orders from med log (53.79)
    38         ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
    39         ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
    40         ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
    41         ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
    42         ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
    43         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
    44         ..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)
    45         ..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)
    46         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
    47         .I $P(PSBUIDS,U,1)="I" Q  ; IV parameters say bag is invalid
    48         .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
    49         .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
    50         .S PSBUIDP=$P(PSBUIDS,U,10,999)
    51         .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY=""  D
    52         ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
    53         ..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
    54         ..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
    55         .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
    56         .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
    57         F II=1:1 S I=$P(PSBONXS,U,II) Q:I=""  D  ; get ward stocks
    58         .S PSBUID="" F  S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID=""  D
    59         ..I PSBUID'["WS" Q  ; not a ward stock
    60         ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
    61         ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
    62         ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
    63         ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q  ; want "not completed" on DC'ed orders
    64         ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
    65         ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
    66         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
    67         ..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)
    68         ..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)
    69         ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
    70         S ^TMP("PSB",$J,0)=PSB
    71         K ^TMP("PSBAR",$J)
    72         Q
    73         ;
    74 BAGDTL(RESULTS,PSBUID,PSBORD)   ; bag detail
    75         I $G(DFN)="" S DFN=+PSBUID
    76         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]""
    77         I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
    78         M PSBMLA=^PSB(53.79,PSBIEN)
    79         S X=$P(^PSB(53.79,PSBIEN,0),U,9)
    80         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")
    81         ; comments
    82         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)
    83         ; audit
    84         S PSBGA="" I $D(PSBMLA(.9,0)) D
    85         .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
    86         ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
    87         ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
    88         ..S PSBGA=1
    89         .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
    90         ..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)
    91         ..S PSBGA=1
    92         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
    93         S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
    94         .S PSBPQRY=$Q(@PSBQRY,-1)
    95         .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no previous action
    96         .I $QS(PSBPQRY,2)="C"  S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; previous line is a comment
    97         .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
    98         .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
    99         S RESULTS(0)=PSBCNT-1
    100         K PSBMLA,PSBIEN,PSBTMP,PSBQRY
    101         Q
    102         ;
    103 INITIAL(PSBDUZ) ;
    104         Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
    105 SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
    106         ;
    107         ; RPC: PSB SCANMED
    108         ;
    109         ; Description:
    110         ; Does a lookup on file 50 returns -1 on invalid lookup or
    111         ; IEN^DrugName on success
    112         ;
    113         D NOW^%DTC S PSBDT=%
    114         S PSBCNT=0
    115         I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
    116         S RESULTS(PSBCNT)=1
    117         S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
    118         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)
    119         I PSBTAB="UDTAB" D  Q
    120         .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
    121         .I X<1 Q
    122         .E  S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
    123         ;
    124         ; IV/IVPB ward stock scan
    125         ;
    126         S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
    127         S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
    128         I $D(^PSDRUG("A527",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X=""  D
    129         .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
    130         .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
    131         I $D(^PSDRUG("A526",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X=""  D
    132         .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
    133         .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
    134         ;
    135         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
    136         Q
    137         ;
     1PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM  30 Jan 2008
     2 ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08
     3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
     4 ;
     5 ;Modified from FOIA VISTA,
     6 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23 ; Reference/IA
     24 ; File 50/221
     25 ; File 52.6/436
     26 ; File 52.7/437
     27 ; File 200/10060
     28GETOHIST(RESULTS,DFN,PSBORD) ;
     29 S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
     30 S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
     31 D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
     32 D EN^PSBPOIV(DFN,PSBORD)
     33 S PSBUID=DFN_"V"_99999 F  S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID=""  D
     34 .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
     35 .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
     36 .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
     37 .I $P(PSBUIDS,U,2)'="" D  Q  ; get orders from med log (53.79)
     38 ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
     39 ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
     40 ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
     41 ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
     42 ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
     43 ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
     44 ..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)
     45 ..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)
     46 ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
     47 .I $P(PSBUIDS,U,1)="I" Q  ; IV parameters say bag is invalid
     48 .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
     49 .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
     50 .S PSBUIDP=$P(PSBUIDS,U,10,999)
     51 .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY=""  D
     52 ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
     53 ..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
     54 ..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
     55 .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
     56 .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
     57 F II=1:1 S I=$P(PSBONXS,U,II) Q:I=""  D  ; get ward stocks
     58 .S PSBUID="" F  S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID=""  D
     59 ..I PSBUID'["WS" Q  ; not a ward stock
     60 ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
     61 ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
     62 ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
     63 ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q  ; want "not completed" on DC'ed orders
     64 ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
     65 ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
     66 ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
     67 ..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)
     68 ..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)
     69 ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
     70 S ^TMP("PSB",$J,0)=PSB
     71 K ^TMP("PSBAR",$J)
     72 Q
     73 ;
     74BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
     75 I $G(DFN)="" S DFN=+PSBUID
     76 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]""
     77 I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
     78 M PSBMLA=^PSB(53.79,PSBIEN)
     79 S X=$P(^PSB(53.79,PSBIEN,0),U,9)
     80 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")
     81 ; comments
     82 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)
     83 ; audit
     84 S PSBGA="" I $D(PSBMLA(.9,0)) D
     85 .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
     86 ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
     87 ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
     88 ..S PSBGA=1
     89 .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
     90 ..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)
     91 ..S PSBGA=1
     92 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
     93 S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
     94 .S PSBPQRY=$Q(@PSBQRY,-1)
     95 .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no previous action
     96 .I $QS(PSBPQRY,2)="C"  S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; previous line is a comment
     97 .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
     98 .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
     99 S RESULTS(0)=PSBCNT-1
     100 K PSBMLA,PSBIEN,PSBTMP,PSBQRY
     101 Q
     102 ;
     103INITIAL(PSBDUZ) ;
     104 Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
     105SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
     106 ;
     107 ; RPC: PSB SCANMED
     108 ;
     109 ; Description:
     110 ; Does a lookup on file 50 returns -1 on invalid lookup or
     111 ; IEN^DrugName on success
     112 ;
     113 D NOW^%DTC S PSBDT=%
     114 S PSBCNT=0
     115 I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
     116 S RESULTS(PSBCNT)=1
     117 S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
     118 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)
     119 I PSBTAB="UDTAB" D  Q
     120 .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
     121 .I X<1 Q
     122 .E  S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
     123 ;
     124 ; IV/IVPB ward stock scan
     125 ;
     126 S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
     127 S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
     128 I $D(^PSDRUG("A527",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X=""  D
     129 .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
     130 .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
     131 I $D(^PSDRUG("A526",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X=""  D
     132 .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
     133 .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
     134 ;
     135 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
     136 Q
     137 ;
Note: See TracChangeset for help on using the changeset viewer.