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/PHARMACY_BENEFITS_MANAGEMENT-PSU
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUCP.m

    r613 r623  
    1 PSUCP   ;BIR/TJH,PDW - PBM CONTROL POINT ; 06/08/07
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
    3         ; Reference to File #4    supported by DBIA 10090
    4         ; Reference to File #4.3  supported by DBIA 10091
    5         ; Reference to File #40.8 supported by DBIA 2438
    6         ; Reference to File #59.7 supported by DBIA 2854
    7         ; move CLEANUP^PSUHL from PSURT1, delete calls to PSUCP3 (PSU*4*12)
    8 MANUAL  ; entry point for manual option
    9         S PSUALERT=0 D MANUAL^PSUALERT
    10         I PSUALERT K PSUALERT Q
    11         K PSUALERT
    12         S PSUFQ=1
    13         I $D(^XTMP("PSUJFLG")) D  Q:Y=0  Q:Y="^"
    14         .W !!,"NOTE: A PREVIOUS JOB HAS NOT COMPLETED DUE TO AN ERROR"
    15         .W !!,"PLEASE ALERT YOUR IRM."
    16         .W !!,"RESPOND 'YES' TO CONTINUE, OR 'NO' TO EXIT"
    17         .S DIR(0)="Y",DIR("B")="NO"
    18         .S DIR("A")="Do you wish to continue"
    19         .D ^DIR
    20         D CLEANUP^PSUHL
    21         S PSUJOB=$J_"_"_$P($H,",",2)
    22         S ^XTMP("PSUMANL")=""
    23         D EN^PSUCP1 ; prompt for report choices
    24         I PSUERR G EXIT
    25         D XMY^PSUTL1 ; Setup for mail groups according to choices
    26         S ^XTMP("PSUJFLG")="",PSUAUTO=0,^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
    27         D PUT
    28         S PSUTITLE="PSU PBM MANUAL",PSURC="RUN^PSUCP"
    29         S PSURP=$S('$L(PSUIOP):"",1:"PRINT^PSUCP")
    30         S PSURX="EXIT^PSUCP",PSUNS="PS"
    31         S ^XTMP("PSU","RUNNING")=$G(ZTSK)
    32         K PSUALERT,XAQ,SQAFLG,SQAID,XQAMSG,XQMSG,ZTSK
    33         D ^PSUDBQUE
    34 MANUALQ Q
    35         ;
    36 AUTO    ; set variables for Auto-report option and task to background
    37         S PSUALERT=0 D AUTO^PSUALERT
    38         I PSUALERT K PSUALERT Q
    39         I $D(^XTMP("PSU","RUNNING")) D  Q
    40         .S XQA(DUZ)="",XQA("G.PSU PBM")="",XQMSG="An ERROR has occurred. Please contact IRM for assistance."
    41         .S XQAID="PSU",XQAFLG="D" D SETUP^XQALERT
    42         D CLEANUP^PSUHL
    43         S PSUJOB=$J_"_"_$P($H,",",2)
    44         S ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")=""   ;flag for mail patient summary reports
    45         S ^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")=1         ;Set 'auto' flag
    46         S ^XTMP("PSUJFLG")=""    ;FLAG to avoid concurrent jobs running
    47         D  ; schedule job completion check
    48         .S PSURC="AUTO^PSUCP2",PSUTITLE="PSU PBM JOB CHECK",PSUFQ=1
    49         .S (PSURP,PSURX,PSUIOP)=""
    50         .D NOW^%DTC S X1=%,X2=6 D C^%DTC S PSUDTH=X ; LIVE MODE, wait 6 days (72 hours)
    51         .D ^PSUDBQUE
    52         .S ^XTMP("PSU","RUNNING")=$G(ZTSK)
    53         D NOW^%DTC S PSUMON=$S('$D(DT):X,1:DT),PSUMON=$E(PSUMON,1,5)-1 ; get previous month
    54         I $E(PSUMON,4,5)="00" S PSUMON=($E(PSUMON,1,3)-1)_"12" ; set to Dec. of previous year if this month is Jan.
    55         S ^XTMP("PSU_"_PSUJOB,"PSUMONTH")=PSUMON,PSUSDT=PSUMON_"01"
    56         S PSULY=$$LEAPYR(PSUMON),X=U_$E(PSUMON,4,5)_U
    57         S PSUEDT=PSUMON_$S(X["02":$S(PSULY:"29",1:"28"),"^04^06^09^11^"[X:"30",1:"31")
    58         S PSUDUZ=$S(DUZ=0:.5,1:DUZ),PSUMASF=1,PSUSMRY=0,PSUPBMG=1
    59         S ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")=1   ;Flag-detailed PD won't go to user auto extract
    60         S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
    61         S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13",PSUAUTO=1,PSUIOP="" D
    62         .S ^XTMP("PSU_"_PSUJOB,"CBAMIS")=""
    63         S ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
    64         D PUT
    65         S PSUTITLE="PSU PBM AUTO",PSURC="RUN^PSUCP",PSURX="EXIT^PSUCP",PSURP="",PSUNS="PS",PSUFQ=1
    66         D NOW^%DTC S PSUDTH=%
    67         D ^PSUDBQUE
    68         K PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK
    69 AUTOQ   Q  ; exit from AUTO
    70         ;
    71 RUN     ; run each selected module
    72         L ^XTMP("PSU","RUNNING"):1 I '$T Q
    73         D PULL,OPTS
    74         K PSUMOD,PSUFDA
    75         I PSUAUTO S PSUFDA(59.7,"1,",90)="@" D FILE^DIE("","PSUFDA","")
    76         F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
    77         S PSUOPTN=""
    78         F  S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN=""  D
    79         .K PSUMSGT
    80         .D PULL
    81         .I PSUAUTO S PSUPBMG=1
    82         .D XMY^PSUTL1
    83         .S PSURTN=PSUA(PSUOPTN,"R")
    84         .D NOW^%DTC
    85         .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"START")=%
    86         .D @PSURTN,PULL,NOW^%DTC
    87         .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"STOP")=%
    88         D DT^DILF("E",PSUSDT,.EXTD)
    89         S PSURP("START")=EXTD(0)
    90         D DT^DILF("E",PSUEDT,.EXTD)
    91         S PSURP("END")=EXTD(0),PSUSUB="PSU_"_PSUJOB
    92         D MMNOMAP^PSUCP2 ; MM send regarding PBM locations not mapped
    93         D TIMING ; send a report of how long each module took to complete
    94         I PSUMASF!PSUPBMG D CONFIRM  ;Confirmation message sent only if data went to Master File
    95         I PSUAUTO D
    96         .D NOW^%DTC
    97         .S PSUFDA(59.7,"1,",90)=% K %,%H,%I,X
    98         .D FILE^DIE("","PSUFDA","") ; file the completion date in 59.7,90;1
    99         L
    100         ;
    101         Q
    102 PRINT   ; print hard copy if requested
    103         Q:'$L(PSUIOP)  ; no printer selected, stop right here.
    104         D PULL,OPTS
    105         K PSUMOD
    106         F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
    107         S PSUOPTN=""
    108         F  S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN=""  D
    109         .D PULL
    110         .S PSURTN=PSUA(PSUOPTN,"P")
    111         .D @PSURTN
    112         L
    113         K ^XTMP("PSU","RUNNING")
    114 PRINTQ   Q
    115 EXIT    ; exit point
    116         K ^XTMP("PSU","RUNNING")
    117         K ^XTMP("PSUJFLG")   ;Remove flag to prevent concurrent jobs
    118         Q
    119 PUT     ; put variables in ^XTMP so modules can retrieve them
    120         S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
    121         S PSUVSTR=""
    122         F I=1:1:$L(PSUVARS,",") S $P(PSUVSTR,U,I)=@$P(PSUVARS,",",I)
    123         S X1=DT,X2=6 D C^%DTC
    124         S ^XTMP("PSU_"_PSUJOB,0)=X_U_DT_U_"Control data for PSU PBM individual modules"
    125         S ^XTMP("PSU_"_PSUJOB,1)=PSUVSTR
    126         K PSUVARS,PSUVSTR,X,X1
    127 PUTQ    Q
    128 PULL    ; pull variables from ^XTMP
    129         ; PSUJOB must exist and must be the job number used to store the data desired for this session.
    130         N I
    131         S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
    132         F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P($G(^XTMP("PSU_"_PSUJOB,1)),U,I)
    133 PULLQ   Q
    134         ;
    135 OPTS    ; set option array
    136         S PSUA(1,"M")="IVs",PSUA(1,"R")="EN^PSUV0",PSUA(1,"P")="PRINT^PSUV0",PSUA(1,"C")="IV"
    137         S PSUA(2,"M")="Unit Dose",PSUA(2,"R")="EN^PSUUD0",PSUA(2,"P")="PRINT^PSUUD0",PSUA(2,"C")="UD"
    138         S PSUA(3,"M")="AR/WS",PSUA(3,"R")="EN^PSUAR0",PSUA(3,"P")="PRINT^PSUAR0",PSUA(3,"C")="AR"
    139         S PSUA(4,"M")="Prescription",PSUA(4,"R")="EN^PSUOP0",PSUA(4,"P")="PRINT^PSUOP0",PSUA(4,"C")="OP"
    140         S PSUA(5,"M")="Procurement",PSUA(5,"R")="EN^PSUPR0",PSUA(5,"P")="PRINT^PSUPR0",PSUA(5,"C")="PR"
    141         S PSUA(6,"M")="Controlled Substances",PSUA(6,"R")="EN^PSUCS0",PSUA(6,"P")="PRINT^PSUCS0",PSUA(6,"C")="CS"
    142         S PSUA(7,"M")="Patient Demographics",PSUA(7,"R")="EN^PSUDEM1",PSUA(7,"P")="PRINT^PSUDEM0",PSUA(7,"C")="PD"
    143         S PSUA(8,"M")="Outpatient Visits",PSUA(8,"R")="EN^PSUDEM2",PSUA(8,"P")="OPV^PSUDEM0",PSUA(8,"C")="OV"
    144         S PSUA(9,"M")="Inpatient PTF Records",PSUA(9,"R")="EN^PSUDEM7",PSUA(9,"P")="PTF^PSUDEM0",PSUA(9,"C")="PTF"
    145         S PSUA(10,"M")="Provider Data",PSUA(10,"R")="EN^PSUDEM4",PSUA(10,"P")="PRO^PSUDEM0",PSUA(10,"C")="PRO"
    146         S PSUA(11,"M")="Allergies/Adverse Events",PSUA(11,"R")="EN^PSUAA1",PSUA(11,"P")="PRINT^PSUAA1",PSUA(11,"C")="AA"
    147         S PSUA(12,"M")="Vitals/Immunizations Information",PSUA(12,"R")="EN^PSUVIT1",PSUA(12,"P")="EN^PSUVIT0",PSUA(12,"C")="VI"
    148         S PSUA(13,"M")="Laboratory Results",PSUA(13,"R")="EN^PSULR0",PSUA(13,"P")="PRINT^PSULR0",PSUA(13,"C")="LR"
    149         S PSUA("A")=""
    150 OPTSQ   Q
    151         ;
    152 CONFIRM ;Send confirmation by Division(s)
    153         K PSUCONF
    154         S PSUDIV=0,$P(PSUDASH,"-",81)=""
    155         D OPTS
    156         S PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted"
    157         S PSUCONF(2)="by the PBM "_$S($G(PSUAUTO):"Automatic",$G(PSURXMT):"RETRANSMISSION",1:"Manual")_" Pharmacy Statistics option."
    158         ; S PSUCONF(2)="by the PBM "_$S(PSUAUTO:"Automatic",1:"Manual")_" Pharmacy Statistics option."
    159         S PSUCONF(3)=" "
    160         S PSUCONF(4)="PACKAGE"_$J("# Line items",35)_$J("# MailMan msgs",19)
    161         S PSUCONF(5)=$E(PSUDASH,1,79)
    162         F  S PSUDIV=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV)) Q:PSUDIV'?1N.E  D
    163         .K ^XTMP(PSUSUB,"XMD")
    164         .M ^XTMP(PSUSUB,"XMD")=PSUCONF
    165         .S PSUOPT=0,PSULCT=5
    166         .F  S PSUOPT=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT)) Q:PSUOPT'?1.N  D
    167         ..S PSULCT=PSULCT+1
    168         ..S PSUPKG=PSUA(PSUOPT,"M")
    169         ..S PSULIN=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"L")
    170         ..S PSUMSG=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"M")
    171         ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12)
    172         ..Q:PSUPKG'="Prescription"  ;*
    173         .. ; process Prescription MultiDose
    174         ..S PSULCT=PSULCT+1
    175         ..S PSUPKG="Prescription MultiDose"
    176         ..S PSULIN=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"L"))
    177         ..S PSUMSG=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"M"))
    178         ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) ;*
    179         .S PSUSUBJ="PBM Stats for "
    180         .I $G(PSUMASF)!$G(PSUDUZ)!$G(PSUPBMG) D XMD
    181 CONFIRMQ        Q
    182         ;
    183 XMD     ;Email
    184         ;
    185         S XMDUZ=DUZ
    186         D XMY^PSUTL1
    187         M XMY=PSUXMYS1
    188         I $G(PSUMASF)!$G(PSUPBMG) M XMY=PSUXMYH
    189         S X=PSUDIV,DIC=40.8,DIC(0)="XM" D ^DIC
    190         S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
    191         S XMSUB=PSUSUBJ_PSURP("START")_" to "_PSURP("END")_" from "_PSUDIV_" "_PSUDIVNM
    192         S XMTEXT="^XTMP(PSUSUB,""XMD"","
    193         S XMCHAN=1
    194         D ^XMD
    195 XMDQ    Q
    196         ;
    197 TIMING  ; Timing report
    198         K ^XTMP(PSUSUB,"XMD")
    199         S $P(PSUSPACE," ",41)=""
    200         S PSUX=0,PSULCT=0
    201         F  S PSUX=$O(^XTMP(PSUSUB,"STATUS",PSUX)) Q:PSUX=""  D
    202         .S (X,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"START") X ^DD("DD") D
    203         ..I $E(Y,17)=":" S PSUT1=$E(Y,1,16)
    204         ..I $E(Y,17)'=":" S PSUT1=$E(Y,1,17)
    205         .S (X1,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"STOP") X ^DD("DD") D
    206         ..I $E(Y,17)=":" S PSUT2=$E(Y,1,16)
    207         ..I $E(Y,17)'=":" S PSUT2=$E(Y,1,17)
    208         .S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1)
    209         .D ^%DTC:X S X=X*1440+Y
    210         .S PSULCT=PSULCT+1
    211         .S PSUREC=$E(PSUA(PSUX,"M")_PSUSPACE,1,20)_$J(PSUT1,20)_$J(PSUT2,20)_$J(X\60,4)_" hrs,"_$J(X#60,3)_" min"
    212         .S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUREC
    213         S PSULCT=PSULCT+1
    214         S $P(^XTMP(PSUSUB,"XMD",PSULCT),"-",80)="" S PSULCT=PSULCT+1
    215         S ^XTMP(PSUSUB,"XMD",PSULCT)="" S PSULCT=PSULCT+1
    216         S ^XTMP(PSUSUB,"XMD",PSULCT)="**NOTE:  Timing for the Provider Data extract is not recorded when" S PSULCT=PSULCT+1
    217         S ^XTMP(PSUSUB,"XMD",PSULCT)="         the IV, Unit Dose, Prescription, and Patient Demographics extracts" S PSULCT=PSULCT+1
    218         S ^XTMP(PSUSUB,"XMD",PSULCT)="         are run concurrently."
    219         S PSUDIV=PSUSNDR
    220         S PSUSUBJ="PBM TIMING for report "
    221         D XMD
    222 TIMINGQ Q
    223         ;
    224 LEAPYR(FMYR)    ; Check to see if year is a leap year: 1=leap year, 0=not leap year
    225         N YYYY
    226         S YYYY=1700+$E(FMYR,1,3)
    227         Q (((YYYY#4=0)&(YYYY#100'=0))!((YYYY#100=0)&(YYYY#400=0)))
     1PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ;25 AUG 1998
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ; Reference to File #4    supported by DBIA 10090
     4 ; Reference to File #4.3  supported by DBIA 10091
     5 ; Reference to File #40.8 supported by DBIA 2438
     6 ; Reference to File #59.7 supported by DBIA 2854
     7MANUAL ; entry point for manual option
     8 S PSUALERT=0 D MANUAL^PSUALERT
     9 I PSUALERT K PSUALERT Q
     10 K PSUALERT
     11 S PSUFQ=1
     12 I $D(^XTMP("PSUJFLG")) D  Q:Y=0  Q:Y="^"
     13 .W !!,"NOTE: A PREVIOUS JOB HAS NOT COMPLETED DUE TO AN ERROR"
     14 .W !!,"PLEASE ALERT YOUR IRM."
     15 .W !!,"RESPOND 'YES' TO CONTINUE, OR 'NO' TO EXIT"
     16 .S DIR(0)="Y",DIR("B")="NO"
     17 .S DIR("A")="Do you wish to continue"
     18 .D ^DIR
     19 D ^PSUCP3
     20 S PSUJOB=$J_"_"_$P($H,",",2)
     21 S ^XTMP("PSUMANL")=""
     22 D EN^PSUCP1 ; prompt for report choices
     23 I PSUERR G EXIT
     24 D XMY^PSUTL1 ; Setup for mail groups according to choices
     25 S ^XTMP("PSUJFLG")="",PSUAUTO=0,^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
     26 D PUT
     27 S PSUTITLE="PSU PBM MANUAL",PSURC="RUN^PSUCP"
     28 S PSURP=$S('$L(PSUIOP):"",1:"PRINT^PSUCP")
     29 S PSURX="EXIT^PSUCP",PSUNS="PS"
     30 S ^XTMP("PSU","RUNNING")=$G(ZTSK)
     31 K PSUALERT,XAQ,SQAFLG,SQAID,XQAMSG,XQMSG,ZTSK
     32 D ^PSUDBQUE
     33MANUALQ Q
     34 ;
     35AUTO ; set variables for Auto-report option and task to background
     36 S PSUALERT=0 D AUTO^PSUALERT
     37 I PSUALERT K PSUALERT Q
     38 I $G(^XTMP("PSU","RUNNING")) D  Q
     39 .S XQA(DUZ)="",XQA("G.PSU PBM")="",XQMSG="An ERROR has occurred. Please contact IRM for assistance."
     40 .S XQAID="PSU",XQAFLG="D" D SETUP^XQALERT
     41 D ^PSUCP3         ;Clear trash globals
     42 S PSUJOB=$J_"_"_$P($H,",",2)
     43 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")=""   ;flag for mail patient summary reports
     44 S ^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")=1         ;Set 'auto' flag
     45 S ^XTMP("PSUJFLG")=""    ;FLAG to avoid concurrent jobs running
     46 D  ; schedule job completion check
     47 .S PSURC="AUTO^PSUCP2",PSUTITLE="PSU PBM JOB CHECK",PSUFQ=1
     48 .S (PSURP,PSURX,PSUIOP)=""
     49 .D NOW^%DTC S X1=%,X2=6 D C^%DTC S PSUDTH=X ; LIVE MODE, wait 6 days (72 hours)
     50 .D ^PSUDBQUE
     51 .S ^XTMP("PSU","RUNNING")=$G(ZTSK)
     52 D NOW^%DTC S PSUMON=$S('$D(DT):X,1:DT),PSUMON=$E(PSUMON,1,5)-1 ; get previous month
     53 I $E(PSUMON,4,5)="00" S PSUMON=($E(PSUMON,1,3)-1)_"12" ; set to Dec. of previous year if this month is Jan.
     54 S ^XTMP("PSU_"_PSUJOB,"PSUMONTH")=PSUMON,PSUSDT=PSUMON_"01"
     55 S PSULY=$$LEAPYR(PSUMON),X=U_$E(PSUMON,4,5)_U
     56 S PSUEDT=PSUMON_$S(X["02":$S(PSULY:"29",1:"28"),"^04^06^09^11^"[X:"30",1:"31")
     57 S PSUDUZ=$S(DUZ=0:.5,1:DUZ),PSUMASF=1,PSUSMRY=0,PSUPBMG=1
     58 S ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")=1   ;Flag-detailed PD won't go to user auto extract
     59 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
     60 S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13",PSUAUTO=1,PSUIOP="" D
     61 .S ^XTMP("PSU_"_PSUJOB,"CBAMIS")=""
     62 S ^XTMP("PSU_"_PSUJOB,"PSUJOB")=PSUJOB
     63 D PUT
     64 S PSUTITLE="PSU PBM AUTO",PSURC="RUN^PSUCP",PSURX="EXIT^PSUCP",PSURP="",PSUNS="PS",PSUFQ=1
     65 D NOW^%DTC S PSUDTH=%
     66 D ^PSUDBQUE
     67 K PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK
     68AUTOQ D EXIT Q  ; exit from AUTO
     69 ;
     70RUN ; run each selected module
     71 L ^XTMP("PSU","RUNNING"):1 I '$T Q
     72 D PULL,OPTS
     73 K PSUMOD,PSUFDA
     74 I PSUAUTO S PSUFDA(59.7,"1,",90)="@" D FILE^DIE("","PSUFDA","")
     75 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
     76 S PSUOPTN=""
     77 F  S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN=""  D
     78 .K PSUMSGT
     79 .D PULL
     80 .I PSUAUTO S PSUPBMG=1
     81 .D XMY^PSUTL1
     82 .S PSURTN=PSUA(PSUOPTN,"R")
     83 .D NOW^%DTC
     84 .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"START")=%
     85 .D @PSURTN,PULL,NOW^%DTC
     86 .S ^XTMP("PSU_"_PSUJOB,"STATUS",PSUOPTN,"STOP")=%
     87 D DT^DILF("E",PSUSDT,.EXTD)
     88 S PSURP("START")=EXTD(0)
     89 D DT^DILF("E",PSUEDT,.EXTD)
     90 S PSURP("END")=EXTD(0),PSUSUB="PSU_"_PSUJOB
     91 D MMNOMAP^PSUCP2 ; MM send regarding PBM locations not mapped
     92 D TIMING ; send a report of how long each module took to complete
     93 I PSUMASF!PSUPBMG D CONFIRM  ;Confirmation message sent only if data went to Master File
     94 I PSUAUTO D
     95 .D NOW^%DTC
     96 .S PSUFDA(59.7,"1,",90)=% K %,%H,%I,X
     97 .D FILE^DIE("","PSUFDA","") ; file the completion date in 59.7,90;1
     98 L
     99 ;
     100 Q
     101PRINT ; print hard copy if requested
     102 Q:'$L(PSUIOP)  ; no printer selected, stop right here.
     103 D PULL,OPTS
     104 K PSUMOD
     105 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
     106 S PSUOPTN=""
     107 F  S PSUOPTN=$O(PSUMOD(PSUOPTN)) Q:PSUOPTN=""  D
     108 .D PULL
     109 .S PSURTN=PSUA(PSUOPTN,"P")
     110 .D @PSURTN
     111 L
     112 K ^XTMP("PSU","RUNNING")
     113PRINTQ  Q
     114EXIT ; exit point
     115 K ^XTMP("PSU","RUNNING")
     116 K ^XTMP("PSUJFLG")   ;Remove flag to prevent concurrent jobs
     117 Q
     118PUT ; put variables in ^XTMP so modules can retrieve them
     119 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
     120 S PSUVSTR=""
     121 F I=1:1:$L(PSUVARS,",") S $P(PSUVSTR,U,I)=@$P(PSUVARS,",",I)
     122 S X1=DT,X2=6 D C^%DTC
     123 S ^XTMP("PSU_"_PSUJOB,0)=X_U_DT_U_"Control data for PSU PBM individual modules"
     124 S ^XTMP("PSU_"_PSUJOB,1)=PSUVSTR
     125 K PSUVARS,PSUVSTR,X,X1
     126PUTQ Q
     127PULL ; pull variables from ^XTMP
     128 ; PSUJOB must exist and must be the job number used to store the data desired for this session.
     129 N I
     130 S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUIOP,PSUSNDR,PSUOPTS,PSUAUTO"
     131 F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P($G(^XTMP("PSU_"_PSUJOB,1)),U,I)
     132PULLQ Q
     133 ;
     134OPTS ; set option array
     135 S PSUA(1,"M")="IVs",PSUA(1,"R")="EN^PSUV0",PSUA(1,"P")="PRINT^PSUV0",PSUA(1,"C")="IV"
     136 S PSUA(2,"M")="Unit Dose",PSUA(2,"R")="EN^PSUUD0",PSUA(2,"P")="PRINT^PSUUD0",PSUA(2,"C")="UD"
     137 S PSUA(3,"M")="AR/WS",PSUA(3,"R")="EN^PSUAR0",PSUA(3,"P")="PRINT^PSUAR0",PSUA(3,"C")="AR"
     138 S PSUA(4,"M")="Prescription",PSUA(4,"R")="EN^PSUOP0",PSUA(4,"P")="PRINT^PSUOP0",PSUA(4,"C")="OP"
     139 S PSUA(5,"M")="Procurement",PSUA(5,"R")="EN^PSUPR0",PSUA(5,"P")="PRINT^PSUPR0",PSUA(5,"C")="PR"
     140 S PSUA(6,"M")="Controlled Substances",PSUA(6,"R")="EN^PSUCS0",PSUA(6,"P")="PRINT^PSUCS0",PSUA(6,"C")="CS"
     141 S PSUA(7,"M")="Patient Demographics",PSUA(7,"R")="EN^PSUDEM1",PSUA(7,"P")="PRINT^PSUDEM0",PSUA(7,"C")="PD"
     142 S PSUA(8,"M")="Outpatient Visits",PSUA(8,"R")="EN^PSUDEM2",PSUA(8,"P")="OPV^PSUDEM0",PSUA(8,"C")="OV"
     143 S PSUA(9,"M")="Inpatient PTF Records",PSUA(9,"R")="EN^PSUDEM7",PSUA(9,"P")="PTF^PSUDEM0",PSUA(9,"C")="PTF"
     144 S PSUA(10,"M")="Provider Data",PSUA(10,"R")="EN^PSUDEM4",PSUA(10,"P")="PRO^PSUDEM0",PSUA(10,"C")="PRO"
     145 S PSUA(11,"M")="Allergies/Adverse Events",PSUA(11,"R")="EN^PSUAA1",PSUA(11,"P")="PRINT^PSUAA1",PSUA(11,"C")="AA"
     146 S PSUA(12,"M")="Vitals/Immunizations Information",PSUA(12,"R")="EN^PSUVIT1",PSUA(12,"P")="EN^PSUVIT0",PSUA(12,"C")="VI"
     147 S PSUA(13,"M")="Laboratory Results",PSUA(13,"R")="EN^PSULR0",PSUA(13,"P")="PRINT^PSULR0",PSUA(13,"C")="LR"
     148 S PSUA("A")=""
     149OPTSQ Q
     150 ;
     151CONFIRM ;Send confirmation by Division(s)
     152 K PSUCONF
     153 S PSUDIV=0,$P(PSUDASH,"-",81)=""
     154 D OPTS
     155 S PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted"
     156 S PSUCONF(2)="by the PBM "_$S($G(PSUAUTO):"Automatic",$G(PSURXMT):"RETRANSMISSION",1:"Manual")_" Pharmacy Statistics option."
     157 ; S PSUCONF(2)="by the PBM "_$S(PSUAUTO:"Automatic",1:"Manual")_" Pharmacy Statistics option."
     158 S PSUCONF(3)=" "
     159 S PSUCONF(4)="PACKAGE"_$J("# Line items",35)_$J("# MailMan msgs",19)
     160 S PSUCONF(5)=$E(PSUDASH,1,79)
     161 F  S PSUDIV=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV)) Q:PSUDIV'?1N.E  D
     162 .K ^XTMP(PSUSUB,"XMD")
     163 .M ^XTMP(PSUSUB,"XMD")=PSUCONF
     164 .S PSUOPT=0,PSULCT=5
     165 .F  S PSUOPT=$O(^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT)) Q:PSUOPT'?1.N  D
     166 ..S PSULCT=PSULCT+1
     167 ..S PSUPKG=PSUA(PSUOPT,"M")
     168 ..S PSULIN=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"L")
     169 ..S PSUMSG=^XTMP(PSUSUB,"CONFIRM",PSUDIV,PSUOPT,"M")
     170 ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12)
     171 ..Q:PSUPKG'="Prescription"  ;*
     172 .. ; process Prescription MultiDose
     173 ..S PSULCT=PSULCT+1
     174 ..S PSUPKG="Prescription MultiDose"
     175 ..S PSULIN=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"L"))
     176 ..S PSUMSG=+$G(^XTMP(PSUSUB,"CONFIRMD",PSUDIV,PSUOPT,"M"))
     177 ..S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUPKG_$J(PSULIN,37-$L(PSUPKG))_$J(PSUMSG,12) ;*
     178 .S PSUSUBJ="PBM Stats for "
     179 .I $G(PSUMASF)!$G(PSUDUZ)!$G(PSUPBMG) D XMD
     180CONFIRMQ Q
     181 ;
     182XMD ;Email
     183 ;
     184 S XMDUZ=DUZ
     185 D XMY^PSUTL1
     186 M XMY=PSUXMYS1
     187 I $G(PSUMASF)!$G(PSUPBMG) M XMY=PSUXMYH
     188 S X=PSUDIV,DIC=40.8,DIC(0)="XM" D ^DIC
     189 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
     190 S XMSUB=PSUSUBJ_PSURP("START")_" to "_PSURP("END")_" from "_PSUDIV_" "_PSUDIVNM
     191 S XMTEXT="^XTMP(PSUSUB,""XMD"","
     192 S XMCHAN=1
     193 D ^XMD
     194XMDQ Q
     195 ;
     196TIMING ; Timing report
     197 K ^XTMP(PSUSUB,"XMD")
     198 S $P(PSUSPACE," ",41)=""
     199 S PSUX=0,PSULCT=0
     200 F  S PSUX=$O(^XTMP(PSUSUB,"STATUS",PSUX)) Q:PSUX=""  D
     201 .S (X,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"START") X ^DD("DD") D
     202 ..I $E(Y,17)=":" S PSUT1=$E(Y,1,16)
     203 ..I $E(Y,17)'=":" S PSUT1=$E(Y,1,17)
     204 .S (X1,Y)=^XTMP(PSUSUB,"STATUS",PSUX,"STOP") X ^DD("DD") D
     205 ..I $E(Y,17)=":" S PSUT2=$E(Y,1,16)
     206 ..I $E(Y,17)'=":" S PSUT2=$E(Y,1,17)
     207 .S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1)
     208 .D ^%DTC:X S X=X*1440+Y
     209 .S PSULCT=PSULCT+1
     210 .S PSUREC=$E(PSUA(PSUX,"M")_PSUSPACE,1,20)_$J(PSUT1,20)_$J(PSUT2,20)_$J(X\60,4)_" hrs,"_$J(X#60,3)_" min"
     211 .S ^XTMP(PSUSUB,"XMD",PSULCT)=PSUREC
     212 S PSULCT=PSULCT+1
     213 S $P(^XTMP(PSUSUB,"XMD",PSULCT),"-",80)="" S PSULCT=PSULCT+1
     214 S ^XTMP(PSUSUB,"XMD",PSULCT)="" S PSULCT=PSULCT+1
     215 S ^XTMP(PSUSUB,"XMD",PSULCT)="**NOTE:  Timing for the Provider Data extract is not recorded when" S PSULCT=PSULCT+1
     216 S ^XTMP(PSUSUB,"XMD",PSULCT)="         the IV, Unit Dose, Prescription, and Patient Demographics extracts" S PSULCT=PSULCT+1
     217 S ^XTMP(PSUSUB,"XMD",PSULCT)="         are run concurrently."
     218 S PSUDIV=PSUSNDR
     219 S PSUSUBJ="PBM TIMING for report "
     220 D XMD
     221TIMINGQ Q
     222 ;
     223LEAPYR(FMYR) ; Check to see if year is a leap year: 1=leap year, 0=not leap year
     224 N YYYY
     225 S YYYY=1700+$E(FMYR,1,3)
     226 Q (((YYYY#4=0)&(YYYY#100'=0))!((YYYY#100=0)&(YYYY#400=0)))
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m

    r613 r623  
    1 PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
    3         ;
    4         ;DBIA's
    5         ; Reference to file #27.11  supported by DBIA 2462
    6         ; Reference to file 2       supported by DBIA 10035, 3504
    7         ; Reference to file 200     supported by DBIA 10060
    8         ; Reference to file 55      supported by DBIA 3502
    9         ; Reference to file 4.3     supported by DBIA 2496, 10091
    10         ; Reference to file 4       supported by DBIA 10090
    11         ;
    12 EN      ;EN   Routine control module
    13         ;
    14         D DAT
    15         I $D(^XTMP("PSUMANL")) D DEM     ;Manual entry point  DAM
    16         I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")) D HL7    ;Auto entry point DAM
    17         I '$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) D XMD
    18         K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
    19         ;
    20         I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG"))=1 D
    21         .S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11"
    22         .S PSUAUTO=1
    23         ;
    24         ;
    25         D PULL^PSUCP
    26         F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
    27         ;
    28         I $D(PSUMOD(10)) D PDSSN^PSUDEM4  ;pt. demographics provider msg
    29         ;
    30         K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
    31         K ^XTMP("PSU_"_PSUJOB,"PSUDM")
    32         K ^XTMP("PSU_"_PSUJOB,"PSUDMX")
    33         K PSUDMDFN,PSURAC,PSURDT
    34         Q
    35         ;
    36 HL7     ;This is the Patient Demographics extract that runs only when
    37         ;the PSU PBM [AUTO] option is executed.  It captures demographic
    38         ;information ONLY on new or updated patient.
    39         ;
    40         ; *** PSU*4.0*12 - BAJ -- added QUIT if NULL
    41         F  S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT=""  Q:PSUSDT>PSUEDT  D
    42         . S I=""
    43         . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I=""
    44         . S DFN=$P(^PSUDEM(I,0),U,2)
    45         . S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)=""
    46         K DFN
    47         ;
    48         S DFN=""
    49         F  S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:DFN=""  D DEM1
    50         ;
    51         Q
    52         ;
    53 DAT     ;Date Module
    54         ;
    55         ;Date extract was run
    56         S %H=$H
    57         D YMD^%DTC                   ;Converts $H to FileMan format
    58         ; ** S $P(^TMP("PSUDM",$J),U,3)=X    ;Set extract date in temp global
    59         S PSURDT=X
    60         ;
    61         Q
    62         ;
    63 INST    ;EN  Place institution code sending report into temp global.
    64         ;Institution Mailman info is in file 4.3
    65         ;
    66         S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
    67         S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)=PSUSNDR
    68         S PSUSIT=PSUSNDR
    69         ;
    70         S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ;**1
    71         S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
    72         S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,2)=PSUDIVNM
    73         Q
    74         ;
    75 DEM     ;PULL PATIENT DEMOGRAPHICS. This is run only when user selects
    76         ;PSU PBM [MANUAL] option.  It gather patient demographic information
    77         ;for all patients in the PATIENT file #2.
    78         ;
    79         ;N PSUREC    ;DAM TEST NEW CODE
    80         N PSUREC
    81         K PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
    82         K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
    83         K PSUREC15,PSUDOD,VAEL,VADM
    84         ;
    85         S PSUNAM=0
    86         F  S PSUNAM=$O(^DPT("B",PSUNAM)) Q:PSUNAM=""  D
    87         .S PSUDMDFN=0
    88         .F  S (DFN,PSUDMDFN)=$O(^DPT("B",PSUNAM,PSUDMDFN)) Q:PSUDMDFN=""  D DEM1
    89         Q
    90         ;
    91 DEM1    ;
    92         K PSUREC,PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
    93         K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
    94         K PSUREC15,PSUDOD,VAEL,VADM
    95         S PSUDOD=$P($G(^DPT(PSUDMDFN,.35)),U,1) I PSUDOD,PSUDOD<2980701 Q
    96         Q:'$D(^DPT(PSUDMDFN,0))  S PSUREC1=$G(^DPT(PSUDMDFN,0))
    97         I $P(PSUREC1,U,21)=1 Q
    98         I $E($P(PSUREC1,U,9),1,5)="00000" Q
    99         D DEM^VADPT
    100         D ELIG^VADPT
    101         ;RUN DATE
    102         S $P(PSUREC,U,3)=PSURDT
    103         ;Gender
    104         S PSUREC3=$TR($P(PSUREC1,U,2),"^","'"),$P(PSUREC,U,8)=PSUREC3
    105         ;SSN
    106         S PSUREC4=$TR($P(PSUREC1,U,9),"^","'"),$P(PSUREC,U,12)=PSUREC4
    107         ;DOB
    108         S PSUREC5=$TR($P(PSUREC1,U,3),"^","'"),$P(PSUREC,U,5)=PSUREC5
    109         ;DT PT ENTERED IN FILE
    110         S PSUREC6=$TR($P(PSUREC1,U,16),"^","'"),$P(PSUREC,U,16)=PSUREC6
    111         S PSUREC7=$G(^PS(55,PSUDMDFN,0)),$P(PSUREC,U,17)=$TR($P(PSUREC7,U,7),"^","'")
    112         ;Service Actual/Historical
    113         S $P(PSUREC,U,18)=$TR($P(PSUREC7,U,8),"^","'")
    114         ;PLACE "^" AT END OF RECORD
    115         S $P(PSUREC,U,30)=""
    116         ;SITE SENDING DATA
    117         S $P(PSUREC,U,2)=PSUSNDR
    118         ;RACE
    119         S PSUREC8=$P($G(VADM(8)),U,2),$P(PSUREC,U,7)=PSUREC8
    120         ;PRIMARY ELIG CODE
    121         S PSUREC9=$P($G(VAEL(1)),U,2),$P(PSUREC,U,9)=PSUREC9
    122         D PRIO
    123         ;MEANS TEST STATUS
    124         S PSUREC11=$P($G(VAEL(9)),U,2),$P(PSUREC,U,10)=PSUREC11
    125         D MISC
    126         ;FIND PATIENT ICN-VMP
    127         D ICN
    128         ;PATIENT CURRENT AGE
    129         S PSUREC12=$G(VADM(4)),$P(PSUREC,U,6)=PSUREC12
    130         D ETH
    131         S ^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUDMDFN)=$G(PSUREC)
    132         Q
    133         ;
    134 PRIO    ;Pull Enrollment Priority
    135         ;
    136         S PSUEC=0
    137         F  S PSUEC=$O(^DGEN(27.11,"C",PSUDMDFN,PSUEC)) Q:PSUEC=""  D
    138         .S PSUREC10=$TR($P($G(^DGEN(27.11,PSUEC,0)),U,7),"^","'")
    139         .I PSUREC10'="" S $P(PSUREC,U,11)=PSUREC10
    140         Q
    141         ;
    142 MISC    ;Pulls miscellaneous additional info via EN^DIQ1 call
    143         ;Pulls Date of Death, ICN, Primary Care Provider SSN,
    144         ;Date patient first provided pharmacy care
    145         ;
    146         N PSUDATMP,PSUDDTMP,PSUDTMPA
    147         ;
    148         S PSUDTMPA=$$OUTPTPR^SDUTL3(PSUDMDFN)   ;Prov IEN^EXTERNAL VALUE in temp variable
    149         S PSUDATMP=$P($G(PSUDTMPA),U)       ;Prov IEN
    150         S $P(PSUREC,U,15)=PSUDATMP
    151         I '$D(PSUDATMP)!PSUDATMP=0 S PSUDATMP=99999999999
    152         S $P(PSUREC,U,14)=$$GET1^DIQ(200,PSUDATMP,9,"I")   ;Prov SSN
    153         S $P(PSUREC,U,4)=$S(PSUDOD:PSUDOD\1,1:"")
    154         Q
    155         ;
    156 ICN     ;Find patient ICN
    157         ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
    158         ;
    159         N PSUICN,PSUICN1
    160         S PSUICN=$$GETICN^MPIF001(PSUDMDFN) D
    161         .I PSUICN'[-1 D
    162         ..S $P(PSUREC,U,13)=PSUICN    ;ICN
    163         Q
    164         ;
    165 ETH     ;Ethnicity and multiple race entries
    166         ;
    167         S PSUREC14=$P($G(VADM(11,1)),U,2),$P(PSUREC,U,19)=PSUREC14
    168         ;
    169         S PSURCE=0,C=20,$P(PSUREC,U,C)=""
    170         F  S PSURCE=$O(VADM(12,PSURCE)) Q:PSURCE=""  D       ;Race multiple
    171         .S PSURAC=$P($G(VADM(12,PSURCE)),U,2),$P(PSUREC,U,C)=PSURAC,C=C+1
    172         Q
    173         ;
    174 XMD     ;Format mailman message and send.
    175         ;
    176         S PSUAB=0,PSUPL=1
    177         F  S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)) Q:PSUAB=""  D
    178         .M ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)  ;Global numerical order
    179         .S PSUPL=PSUPL+1
    180         ;
    181         NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
    182         S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
    183         S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
    184         S PSUMC=1,PSUMLC=0
    185         F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSULC)) Q:X=""  D
    186         .S PSUMLC=PSUMLC+1
    187         .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q  ; +  message
    188         .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
    189         .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
    190         .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
    191         .S PSUMLC=PSUMLC+1
    192         .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
    193         ;
    194         ;   Count Lines sent
    195         S PSUTLC=0
    196         F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
    197         ;
    198         F PSUM=1:1:PSUMC D PDMAIL^PSUDEM5
    199         D CONF
    200         Q
    201 CONF    ;Construct globals for confirmation message
    202         ;
    203         N PSUDIVIS
    204         D INST
    205         S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
    206         S PSUSUB="PSU_"_PSUJOB
    207         S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"M")=PSUMC
    208         S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"L")=PSUTLC
    209         Q
    210 REC     ;EN If "^" is contained in any record, replace it with "'"
    211         ;
    212         I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
    213         Q
     1PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;
     4 ;DBIA's
     5 ; Reference to file #27.11  supported by DBIA 2462
     6 ; Reference to file 2       supported by DBIA 10035, 3504
     7 ; Reference to file 200     supported by DBIA 10060
     8 ; Reference to file 55      supported by DBIA 3502
     9 ; Reference to file 4.3     supported by DBIA 2496, 10091
     10 ; Reference to file 4       supported by DBIA 10090
     11 ;
     12EN ;EN   Routine control module
     13 ;
     14 D DAT
     15 I $D(^XTMP("PSUMANL")) D DEM     ;Manual entry point  DAM
     16 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG")) D HL7    ;Auto entry point DAM
     17 I '$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) D XMD
     18 K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
     19 ;
     20 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUMFLAG"))=1 D
     21 .S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11"
     22 .S PSUAUTO=1
     23 ;
     24 ;
     25 D PULL^PSUCP
     26 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
     27 ;
     28 I $D(PSUMOD(10)) D PDSSN^PSUDEM4  ;pt. demographics provider msg
     29 ;
     30 K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
     31 K ^XTMP("PSU_"_PSUJOB,"PSUDM")
     32 K ^XTMP("PSU_"_PSUJOB,"PSUDMX")
     33 K PSUDMDFN,PSURAC,PSURDT
     34 Q
     35 ;
     36HL7 ;This is the Patient Demographics extract that runs only when
     37 ;the PSU PBM [AUTO] option is executed.  It captures demographic
     38 ;information ONLY on new or updated patient.
     39 ;
     40 F  S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT>PSUEDT  D
     41 . S I=""
     42 . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I=""
     43 . S DFN=$P(^PSUDEM(I,0),U,2)
     44 . S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)=""
     45 K DFN
     46 ;
     47 S DFN=""
     48 F  S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:DFN=""  D DEM1
     49 ;
     50 Q
     51 ;
     52DAT ;Date Module
     53 ;
     54 ;Date extract was run
     55 S %H=$H
     56 D YMD^%DTC                   ;Converts $H to FileMan format
     57 ; ** S $P(^TMP("PSUDM",$J),U,3)=X    ;Set extract date in temp global
     58 S PSURDT=X
     59 ;
     60 Q
     61 ;
     62INST ;EN  Place institution code sending report into temp global.
     63 ;Institution Mailman info is in file 4.3
     64 ;
     65 S X=$$VALI^PSUTL(4.3,1,217),PSUSNDR=+$$VAL^PSUTL(4,X,99)
     66 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)=PSUSNDR
     67 S PSUSIT=PSUSNDR
     68 ;
     69 S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ;**1
     70 S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
     71 S $P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,2)=PSUDIVNM
     72 Q
     73 ;
     74DEM ;PULL PATIENT DEMOGRAPHICS. This is run only when user selects
     75 ;PSU PBM [MANUAL] option.  It gather patient demographic information
     76 ;for all patients in the PATIENT file #2.
     77 ;
     78 ;N PSUREC    ;DAM TEST NEW CODE
     79 N PSUREC
     80 K PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
     81 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
     82 K PSUREC15,PSUDOD,VAEL,VADM
     83 ;
     84 S PSUNAM=0
     85 F  S PSUNAM=$O(^DPT("B",PSUNAM)) Q:PSUNAM=""  D
     86 .S PSUDMDFN=0
     87 .F  S (DFN,PSUDMDFN)=$O(^DPT("B",PSUNAM,PSUDMDFN)) Q:PSUDMDFN=""  D DEM1
     88 Q
     89 ;
     90DEM1 ;
     91 K PSUREC,PSUREC1,PSUREC2,PSUREC3,PSUREC4,PSUREC5,PSUREC6,PSUREC7
     92 K PSUREC8,PSUREC9,PSUREC10,PSUREC11,PSUREC12,PSUREC13,PSUREC14
     93 K PSUREC15,PSUDOD,VAEL,VADM
     94 S PSUDOD=$P($G(^DPT(PSUDMDFN,.35)),U,1) I PSUDOD,PSUDOD<2980701 Q
     95 Q:'$D(^DPT(PSUDMDFN,0))  S PSUREC1=$G(^DPT(PSUDMDFN,0))
     96 I $P(PSUREC1,U,21)=1 Q
     97 I $E($P(PSUREC1,U,9),1,5)="00000" Q
     98 D DEM^VADPT
     99 D ELIG^VADPT
     100 ;RUN DATE
     101 S $P(PSUREC,U,3)=PSURDT
     102 ;Gender
     103 S PSUREC3=$TR($P(PSUREC1,U,2),"^","'"),$P(PSUREC,U,8)=PSUREC3
     104 ;SSN
     105 S PSUREC4=$TR($P(PSUREC1,U,9),"^","'"),$P(PSUREC,U,12)=PSUREC4
     106 ;DOB
     107 S PSUREC5=$TR($P(PSUREC1,U,3),"^","'"),$P(PSUREC,U,5)=PSUREC5
     108 ;DT PT ENTERED IN FILE
     109 S PSUREC6=$TR($P(PSUREC1,U,16),"^","'"),$P(PSUREC,U,16)=PSUREC6
     110 S PSUREC7=$G(^PS(55,PSUDMDFN,0)),$P(PSUREC,U,17)=$TR($P(PSUREC7,U,7),"^","'")
     111 ;Service Actual/Historical
     112 S $P(PSUREC,U,18)=$TR($P(PSUREC7,U,8),"^","'")
     113 ;PLACE "^" AT END OF RECORD
     114 S $P(PSUREC,U,30)=""
     115 ;SITE SENDING DATA
     116 S $P(PSUREC,U,2)=PSUSNDR
     117 ;RACE
     118 S PSUREC8=$P($G(VADM(8)),U,2),$P(PSUREC,U,7)=PSUREC8
     119 ;PRIMARY ELIG CODE
     120 S PSUREC9=$P($G(VAEL(1)),U,2),$P(PSUREC,U,9)=PSUREC9
     121 D PRIO
     122 ;MEANS TEST STATUS
     123 S PSUREC11=$P($G(VAEL(9)),U,2),$P(PSUREC,U,10)=PSUREC11
     124 D MISC
     125 ;FIND PATIENT ICN-VMP
     126 D ICN
     127 ;PATIENT CURRENT AGE
     128 S PSUREC12=$G(VADM(4)),$P(PSUREC,U,6)=PSUREC12
     129 D ETH
     130 S ^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUDMDFN)=$G(PSUREC)
     131 Q
     132 ;
     133PRIO ;Pull Enrollment Priority
     134 ;
     135 S PSUEC=0
     136 F  S PSUEC=$O(^DGEN(27.11,"C",PSUDMDFN,PSUEC)) Q:PSUEC=""  D
     137 .S PSUREC10=$TR($P($G(^DGEN(27.11,PSUEC,0)),U,7),"^","'")
     138 .I PSUREC10'="" S $P(PSUREC,U,11)=PSUREC10
     139 Q
     140 ;
     141MISC ;Pulls miscellaneous additional info via EN^DIQ1 call
     142 ;Pulls Date of Death, ICN, Primary Care Provider SSN,
     143 ;Date patient first provided pharmacy care
     144 ;
     145 N PSUDATMP,PSUDDTMP,PSUDTMPA
     146 ;
     147 S PSUDTMPA=$$OUTPTPR^SDUTL3(PSUDMDFN)   ;Prov IEN^EXTERNAL VALUE in temp variable
     148 S PSUDATMP=$P($G(PSUDTMPA),U)       ;Prov IEN
     149 S $P(PSUREC,U,15)=PSUDATMP
     150 I '$D(PSUDATMP)!PSUDATMP=0 S PSUDATMP=99999999999
     151 S $P(PSUREC,U,14)=$$GET1^DIQ(200,PSUDATMP,9,"I")   ;Prov SSN
     152 S $P(PSUREC,U,4)=$S(PSUDOD:PSUDOD\1,1:"")
     153 Q
     154 ;
     155ICN ;Find patient ICN
     156 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
     157 ;
     158 N PSUICN,PSUICN1
     159 S PSUICN=$$GETICN^MPIF001(PSUDMDFN) D
     160 .I PSUICN'[-1 D
     161 ..S $P(PSUREC,U,13)=PSUICN    ;ICN
     162 Q
     163 ;
     164ETH ;Ethnicity and multiple race entries
     165 ;
     166 S PSUREC14=$P($G(VADM(11,1)),U,2),$P(PSUREC,U,19)=PSUREC14
     167 ;
     168 S PSURCE=0,C=20,$P(PSUREC,U,C)=""
     169 F  S PSURCE=$O(VADM(12,PSURCE)) Q:PSURCE=""  D       ;Race multiple
     170 .S PSURAC=$P($G(VADM(12,PSURCE)),U,2),$P(PSUREC,U,C)=PSURAC,C=C+1
     171 Q
     172 ;
     173XMD ;Format mailman message and send.
     174 ;
     175 S PSUAB=0,PSUPL=1
     176 F  S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)) Q:PSUAB=""  D
     177 .M ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUDMX",PSUAB)  ;Global numerical order
     178 .S PSUPL=PSUPL+1
     179 ;
     180 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
     181 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
     182 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
     183 S PSUMC=1,PSUMLC=0
     184 F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSULC)) Q:X=""  D
     185 .S PSUMLC=PSUMLC+1
     186 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q  ; +  message
     187 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
     188 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
     189 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
     190 .S PSUMLC=PSUMLC+1
     191 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
     192 ;
     193 ;   Count Lines sent
     194 S PSUTLC=0
     195 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
     196 ;
     197 F PSUM=1:1:PSUMC D PDMAIL^PSUDEM5
     198 D CONF
     199 Q
     200CONF ;Construct globals for confirmation message
     201 ;
     202 N PSUDIVIS
     203 D INST
     204 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
     205 S PSUSUB="PSU_"_PSUJOB
     206 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"M")=PSUMC
     207 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,7,"L")=PSUTLC
     208 Q
     209REC ;EN If "^" is contained in any record, replace it with "'"
     210 ;
     211 I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
     212 Q
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m

    r613 r623  
    1 PSUDEM4 ;BIR/DAM - Provider Extract ; 4/26/07 4:38pm
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8,12**;MARCH, 2005;Build 19
    3         ;
    4         ;DBIA'S
    5         ; Reference to file 200    supported by DBIA 10060
    6         ; Reference to file 7      supported by DBIA 2495
    7         ; Reference to file 49     supported by DBIA 432
    8         ; Reference to file 8932.1 supported by DBIA 2091
    9         ; Reference to file 4.2    supported by DBIA 2496
    10         ;
    11 EN      ;Entry point for gathering all provider information from IV, UD, Rx,
    12         ;and PD modules.
    13         ;
    14         N PSUREC
    15         S ^XTMP("PSU_"_PSUJOB,"PSUFLAG")=""
    16         ;
    17         D PULL^PSUCP
    18         F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
    19         ;
    20         I '$D(PSUMOD(7)) D EN^PSUDEM1
    21         I '$D(PSUMOD(1)) D EN^PSUV0
    22         I '$D(PSUMOD(2)) D EN^PSUUD0
    23         I '$D(PSUMOD(4)) D
    24         .S ^XTMP("PSU_"_PSUJOB,"PSUOPFLG")=""   ;Set flag
    25         .D EN^PSUOP0
    26         M ^XTMP("PSU_"_PSUJOB,"PSUPROM")=^XTMP("PSU_"_PSUJOB,"PSUPROV")
    27         ;
    28         D XMD
    29         D EN^PSUSUM1      ;compose provider summary report and mail it.
    30         K ^XTMP("PSU_"_PSUJOB,"PSUFLAG")
    31         Q
    32         ;
    33 PDSSN   ;EN  Called from PSUDEM1
    34         ;Find provider SSN and IEN present in the patient demographics
    35         ;extract.  Note that this is the primary care provider.
    36         ;
    37         S PSUT=0
    38         F  S PSUT=$O(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)) Q:'PSUT  D
    39         .N PSUIEN,PSUSSN1
    40         .S PSUIEN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,15) I 'PSUIEN S PSUIEN="UNK"
    41         .D FAC
    42         .D PNAM
    43         .S PSUSSN1=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,14) I 'PSUSSN1 S PSUSSN1=""
    44         .S PSUREC=PSUSSN1 D REC^PSUDEM2
    45         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC              ;Dem Prov SSN
    46         .S PSUREC=PSUIEN D REC^PSUDEM2
    47         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC D              ;Dem Prov ICN
    48         ..I PSUREC="UNK" K ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)
    49         Q
    50         ;
    51 UDSSN   ;EN  Called from PROV^PSUUD1. Find provider SSN and IEN in the unit
    52         ;dose extract
    53         ;
    54         S PSUIEN=0,PSUVSSN1=0
    55         F  S PSUVSSN1=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1)) Q:PSUVSSN1=""  D
    56         .F  S PSUIEN=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIEN)) Q:PSUIEN=""  D
    57         ..D FAC
    58         ..S PSUREC=PSUVSSN1 D REC^PSUDEM1 D
    59         ...I PSUREC=999999999 S PSUREC=""
    60         ...S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC   ;UD Prov SSN
    61         ..S PSUREC=PSUIEN D REC^PSUDEM2
    62         ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC    ;UD Prov IEN
    63         ..D PNAM
    64         Q
    65         ;
    66 IVSSN   ;EN Called from PSUIV1. Gives Provider within date range of extract
    67         ;
    68         D UDSSN
    69         Q
    70         ;
    71 OPSSN   ;EN Called from PSUOP0.  Gives prescription Provider
    72         ;
    73         D UDSSN
    74         Q
    75 FAC     ;Find provider station number.  Places that info in each record.
    76         ;
    77         ;D INST^PSUDEM1
    78         S $P(^TMP("PSUPROV",$J),U,2)=PSUSNDR
    79         M ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)=^TMP("PSUPROV",$J)
    80         Q
    81         ;
    82 PNAM    ;Find the provider's name.
    83         ;
    84         N PSUCLP,PSUSS,PSUSP
    85         ;
    86         ;Find provider name
    87         S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,9)=$$GET1^DIQ(200,PSUIEN,.01,"I")
    88         ;
    89         S PSUCLP=$$GET1^DIQ(200,PSUIEN,53.5,"I") D CLASS  ;Provider pointer
    90         S PSUSS=$$GET1^DIQ(200,PSUIEN,29,"I") D SS        ;Service Sctn ptr
    91         ;
    92         S PSUD1=999
    93         S PSUD1=$O(^VA(200,PSUIEN,"USC1",PSUD1),-1)  ;Find last subscript
    94         I PSUD1'="" D
    95         .S PSUSP=$$GET1^DIQ(200.05,PSUD1_","_PSUIEN_",",.01,"I")  ;Specialty
    96         .D SPEC
    97         I PSUD1="" D
    98         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
    99         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
    100         Q
    101         ;
    102 CLASS   ;Find provider class
    103         ;
    104         I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" Q
    105         I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
    106         I PSUCLP'="" D
    107         .N PSUA
    108         .S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,2)
    109         .I PSUA']"" S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,1)
    110         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=PSUA  ;Prov class
    111         .K PSUA
    112         Q
    113         ;
    114 SS      ;Find Provider Service/Section
    115         ;
    116         N PSUTMP
    117         ;
    118         I PSUSS="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=""
    119         I PSUSS'="" S PSUTMP=1 D
    120         .S:$P($G(^DIC(49,PSUSS,0)),U)["AMBU" PSUTMP="AMB"
    121         .S:$P($G(^DIC(49,PSUSS,0)),U)["ANESTH" PSUTMP="ANES"
    122         .S:$P($G(^DIC(49,PSUSS,0)),U)["CARDIO" PSUTMP="CV"
    123         .S:$P($G(^DIC(49,PSUSS,0)),U)["PHARM" PSUTMP="CPHAR"
    124         .S:$P($G(^DIC(49,PSUSS,0)),U)["DENT" PSUTMP="DDS"
    125         .S:$P($G(^DIC(49,PSUSS,0)),U)["MEDIC" PSUTMP="MED"
    126         .S:$P($G(^DIC(49,PSUSS,0)),U)["INTERMED" PSUTMP="IM"
    127         .S:$P($G(^DIC(49,PSUSS,0)),U)["NUCLEAR" PSUTMP="NUM"
    128         .S:$P($G(^DIC(49,PSUSS,0)),U)["NURSING" PSUTMP="RN"
    129         .S:$P($G(^DIC(49,PSUSS,0)),U)["ORTHOPED" PSUTMP="ORTHO"
    130         .S:$P($G(^DIC(49,PSUSS,0)),U)["PSYCHIA" PSUTMP="PSY"
    131         .S:$P($G(^DIC(49,PSUSS,0)),U)["MENTAL" PSUTMP="PSY"
    132         .S:$P($G(^DIC(49,PSUSS,0)),U)["PRIMARY" PSUTMP="AMB"
    133         .S:$P($G(^DIC(49,PSUSS,0)),U)["CBOC" PSUTMP="AMB"
    134         .S:$P($G(^DIC(49,PSUSS,0)),U)["OPHTH" PSUTMP="OPH"
    135         .S:$P($G(^DIC(49,PSUSS,0)),U)["PULM" PSUTMP="PUL"
    136         .S:$P($G(^DIC(49,PSUSS,0)),U)["RADIOL" PSUTMP="RAD"
    137         .S:$P($G(^DIC(49,PSUSS,0)),U)["SURG" PSUTMP="SUR"
    138         .S:$P($G(^DIC(49,PSUSS,0)),U)["UROLOG" PSUTMP="U"
    139         .S:$P($G(^DIC(49,PSUSS,0)),U)["NEUROL" PSUTMP="NEUR"
    140         .S PSUREC=$G(PSUTMP) D REC^PSUDEM2
    141         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=$G(PSUREC)       ;Prov Serv/Sec
    142         Q
    143         ;
    144 SPEC    ;Find provider specialty and sub-specialty
    145         ;
    146         I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
    147         I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
    148         I PSUSP'="" D
    149         .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,2) D REC^PSUDEM2
    150         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=PSUREC D     ;Speclty
    151         ..I $P(^USC(8932.1,PSUSP,0),U,2)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
    152         .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,3) D REC^PSUDEM2
    153         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=PSUREC D      ;Subspecl
    154         ..I $P(^USC(8932.1,PSUSP,0),U,3)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
    155         ;
    156         Q
    157         ;
    158 XMD     ;Format mailman message and send.
    159         ;
    160         S PSUAA=0
    161         F  S PSUAA=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA)) Q:PSUAA=""  D
    162         .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA),U,9)=""      ;Remove provider name
    163         ;
    164         ;Remove space in piece 8
    165         S PSUAB=0
    166         F  S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB)) Q:PSUAB=""  D
    167         .I $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=" " D
    168         ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=""
    169         ;
    170         S PSUAC=0,PSUPL=1
    171         F  S PSUAC=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)) Q:PSUAC=""  D
    172         .M ^TMP("PSUPROM",$J,PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)  ;numerical order
    173         .S PSUPL=PSUPL+1
    174         ;
    175         NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
    176         S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
    177         S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
    178         S PSUMC=1,PSUMLC=0
    179         F PSULC=1:1 S X=$G(^TMP("PSUPROM",$J,PSULC)) Q:X=""  D
    180         .S PSUMLC=PSUMLC+1
    181         .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q  ; +  message
    182         .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
    183         .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
    184         .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
    185         .S PSUMLC=PSUMLC+1
    186         .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
    187         ;
    188         F PSUM=1:1:PSUMC D PROV^PSUDEM5
    189         D CONF
    190         Q
    191 CONF    ;Construct globals for confirmation message
    192         ;
    193         ;   Count Lines sent
    194         S PSUTLC=0
    195         F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
    196         ;
    197         D INST^PSUDEM1
    198         N PSUDIVIS
    199         S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
    200         S PSUSUB="PSU_"_PSUJOB
    201         S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"M")=PSUMC
    202         S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"L")=PSUTLC
    203         Q
     1PSUDEM4 ;BIR/DAM - Provider Extract ; 7/21/06 2:27pm
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8**;MARCH, 2005
     3 ;
     4 ;DBIA'S
     5 ; Reference to file 200    supported by DBIA 10060
     6 ; Reference to file 7      supported by DBIA 2495
     7 ; Reference to file 49     supported by DBIA 432
     8 ; Reference to file 8932.1 supported by DBIA 2091
     9 ; Reference to file 4.2    supported by DBIA 2496
     10 ;
     11EN ;Entry point for gathering all provider information from IV, UD, Rx,
     12 ;and PD modules.
     13 ;
     14 N PSUREC
     15 S ^XTMP("PSU_"_PSUJOB,"PSUFLAG")=""
     16 ;
     17 D PULL^PSUCP
     18 F I=1:1:$L(PSUOPTS,",") S PSUMOD($P(PSUOPTS,",",I))=""
     19 ;
     20 I '$D(PSUMOD(7)) D EN^PSUDEM1
     21 I '$D(PSUMOD(1)) D EN^PSUV0
     22 I '$D(PSUMOD(2)) D EN^PSUUD0
     23 I '$D(PSUMOD(4)) D
     24 .S ^XTMP("PSU_"_PSUJOB,"PSUOPFLG")=""   ;Set flag
     25 .D EN^PSUOP0
     26 M ^XTMP("PSU_"_PSUJOB,"PSUPROM")=^XTMP("PSU_"_PSUJOB,"PSUPROV")
     27 ;
     28 D XMD
     29 D EN^PSUSUM1      ;compose provider summary report and mail it.
     30 K ^XTMP("PSU_"_PSUJOB,"PSUFLAG")
     31 Q
     32 ;
     33PDSSN ;EN  Called from PSUDEM1
     34 ;Find provider SSN and IEN present in the patient demographics
     35 ;extract.  Note that this is the primary care provider.
     36 ;
     37 S PSUT=0
     38 F  S PSUT=$O(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)) Q:'PSUT  D
     39 .N PSUIEN,PSUSSN1
     40 .S PSUIEN=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,15) I 'PSUIEN S PSUIEN="UNK"
     41 .D FAC
     42 .D PNAM
     43 .S PSUSSN1=$P($G(^XTMP("PSU_"_PSUJOB,"PSUDM",PSUT)),U,14) I 'PSUSSN1 S PSUSSN1=""
     44 .S PSUREC=PSUSSN1 D REC^PSUDEM2
     45 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC              ;Dem Prov SSN
     46 .S PSUREC=PSUIEN D REC^PSUDEM2
     47 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC D              ;Dem Prov ICN
     48 ..I PSUREC="UNK" K ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)
     49 Q
     50 ;
     51UDSSN ;EN  Called from PROV^PSUUD1. Find provider SSN and IEN in the unit
     52 ;dose extract
     53 ;
     54 S PSUIEN=0,PSUVSSN1=0
     55 F  S PSUVSSN1=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1)) Q:PSUVSSN1=""  D
     56 .F  S PSUIEN=$O(^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIEN)) Q:PSUIEN=""  D
     57 ..D FAC
     58 ..S PSUREC=PSUVSSN1 D REC^PSUDEM1 D
     59 ...I PSUREC=999999999 S PSUREC=""
     60 ...S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,3)=PSUREC   ;UD Prov SSN
     61 ..S PSUREC=PSUIEN D REC^PSUDEM2
     62 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,4)=PSUREC    ;UD Prov IEN
     63 ..D PNAM
     64 Q
     65 ;
     66IVSSN ;EN Called from PSUIV1. Gives Provider within date range of extract
     67 ;
     68 D UDSSN
     69 Q
     70 ;
     71OPSSN ;EN Called from PSUOP0.  Gives prescription Provider
     72 ;
     73 D UDSSN
     74 Q
     75FAC ;Find provider station number.  Places that info in each record.
     76 ;
     77 ;D INST^PSUDEM1
     78 S $P(^TMP("PSUPROV",$J),U,2)=PSUSNDR
     79 M ^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN)=^TMP("PSUPROV",$J)
     80 Q
     81 ;
     82PNAM ;Find the provider's name.
     83 ;
     84 N PSUCLP,PSUSS,PSUSP
     85 ;
     86 ;Find provider name
     87 S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,9)=$$GET1^DIQ(200,PSUIEN,.01,"I")
     88 ;
     89 S PSUCLP=$$GET1^DIQ(200,PSUIEN,53.5,"I") D CLASS  ;Provider pointer
     90 S PSUSS=$$GET1^DIQ(200,PSUIEN,29,"I") D SS        ;Service Sctn ptr
     91 ;
     92 S PSUD1=999
     93 S PSUD1=$O(^VA(200,PSUIEN,"USC1",PSUD1),-1)  ;Find last subscript
     94 I PSUD1'="" D
     95 .S PSUSP=$$GET1^DIQ(200.05,PSUD1_","_PSUIEN_",",.01,"I")  ;Specialty
     96 .D SPEC
     97 I PSUD1="" D
     98 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
     99 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
     100 Q
     101 ;
     102CLASS ;Find provider class
     103 ;
     104 I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
     105 I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
     106 I PSUCLP'="" D
     107 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=$P($G(^DIC(7,PSUCLP,0)),U,2)  ;Prov class
     108 Q
     109 ;
     110SS ;Find Provider Service/Section
     111 ;
     112 N PSUTMP
     113 ;
     114 I PSUSS="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=""
     115 I PSUSS'="" S PSUTMP=1 D
     116 .S:$P($G(^DIC(49,PSUSS,0)),U)["AMBU" PSUTMP="AMB"
     117 .S:$P($G(^DIC(49,PSUSS,0)),U)["ANESTH" PSUTMP="ANES"
     118 .S:$P($G(^DIC(49,PSUSS,0)),U)["CARDIO" PSUTMP="CV"
     119 .S:$P($G(^DIC(49,PSUSS,0)),U)["PHARM" PSUTMP="CPHAR"
     120 .S:$P($G(^DIC(49,PSUSS,0)),U)["DENT" PSUTMP="DDS"
     121 .S:$P($G(^DIC(49,PSUSS,0)),U)["MEDIC" PSUTMP="MED"
     122 .S:$P($G(^DIC(49,PSUSS,0)),U)["INTERMED" PSUTMP="IM"
     123 .S:$P($G(^DIC(49,PSUSS,0)),U)["NUCLEAR" PSUTMP="NUM"
     124 .S:$P($G(^DIC(49,PSUSS,0)),U)["NURSING" PSUTMP="RN"
     125 .S:$P($G(^DIC(49,PSUSS,0)),U)["ORTHOPED" PSUTMP="ORTHO"
     126 .S:$P($G(^DIC(49,PSUSS,0)),U)["PSYCHIA" PSUTMP="PSY"
     127 .S:$P($G(^DIC(49,PSUSS,0)),U)["MENTAL" PSUTMP="PSY"
     128 .S:$P($G(^DIC(49,PSUSS,0)),U)["PRIMARY" PSUTMP="AMB"
     129 .S:$P($G(^DIC(49,PSUSS,0)),U)["CBOC" PSUTMP="AMB"
     130 .S:$P($G(^DIC(49,PSUSS,0)),U)["OPHTH" PSUTMP="OPH"
     131 .S:$P($G(^DIC(49,PSUSS,0)),U)["PULM" PSUTMP="PUL"
     132 .S:$P($G(^DIC(49,PSUSS,0)),U)["RADIOL" PSUTMP="RAD"
     133 .S:$P($G(^DIC(49,PSUSS,0)),U)["SURG" PSUTMP="SUR"
     134 .S:$P($G(^DIC(49,PSUSS,0)),U)["UROLOG" PSUTMP="U"
     135 .S:$P($G(^DIC(49,PSUSS,0)),U)["NEUROL" PSUTMP="NEUR"
     136 .S PSUREC=$G(PSUTMP) D REC^PSUDEM2
     137 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,6)=$G(PSUREC)       ;Prov Serv/Sec
     138 Q
     139 ;
     140SPEC ;Find provider specialty and sub-specialty
     141 ;
     142 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
     143 I PSUSP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
     144 I PSUSP'="" D
     145 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,2) D REC^PSUDEM2
     146 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=PSUREC D     ;Speclty
     147 ..I $P(^USC(8932.1,PSUSP,0),U,2)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,7)=""
     148 .S PSUREC=$P($G(^USC(8932.1,PSUSP,0)),U,3) D REC^PSUDEM2
     149 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=PSUREC D      ;Subspecl
     150 ..I $P(^USC(8932.1,PSUSP,0),U,3)="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,8)=""
     151 ;
     152 Q
     153 ;
     154XMD ;Format mailman message and send.
     155 ;
     156 S PSUAA=0
     157 F  S PSUAA=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA)) Q:PSUAA=""  D
     158 .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAA),U,9)=""      ;Remove provider name
     159 ;
     160 ;Remove space in piece 8
     161 S PSUAB=0
     162 F  S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB)) Q:PSUAB=""  D
     163 .I $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=" " D
     164 ..S $P(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAB),U,8)=""
     165 ;
     166 S PSUAC=0,PSUPL=1
     167 F  S PSUAC=$O(^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)) Q:PSUAC=""  D
     168 .M ^TMP("PSUPROM",$J,PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUPROM",PSUAC)  ;numerical order
     169 .S PSUPL=PSUPL+1
     170 ;
     171 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
     172 S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
     173 S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
     174 S PSUMC=1,PSUMLC=0
     175 F PSULC=1:1 S X=$G(^TMP("PSUPROM",$J,PSULC)) Q:X=""  D
     176 .S PSUMLC=PSUMLC+1
     177 .I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q  ; +  message
     178 .I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
     179 .F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
     180 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
     181 .S PSUMLC=PSUMLC+1
     182 .S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
     183 ;
     184 F PSUM=1:1:PSUMC D PROV^PSUDEM5
     185 D CONF
     186 Q
     187CONF ;Construct globals for confirmation message
     188 ;
     189 ;   Count Lines sent
     190 S PSUTLC=0
     191 F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
     192 ;
     193 D INST^PSUDEM1
     194 N PSUDIVIS
     195 S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
     196 S PSUSUB="PSU_"_PSUJOB
     197 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"M")=PSUMC
     198 S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,10,"L")=PSUTLC
     199 Q
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m

    r613 r623  
    1 PSULRHL1        ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 8/1/07 11:26am
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,11**;MARCH, 2005;Build 8
    3         ;
    4         ; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol
    5         ; DBIA 998 to dig through ^DPT(i,"LR" go get the ien to file #63
    6         ; DBIA 91-A to dig through ^LAB(60 to get the name of the test
    7         ; DBIA 3630 to call the HL7 PID builder
    8         ; DBIA 4727 to call EN^HLOCNRT
    9         ; DBIA 3646 to call API: $$EMPL^DGSEC4
    10         ; DBIA 4658 to call API: $$TSTRES^LRRPU
    11         ;
    12         ; This program is called when a lab test is verified. If it is for a
    13         ; chemistry test, and not for an employee, an HL7 message will be
    14         ; created and sent to the CMOP-NAT server.
    15         ;
    16         ;
    17 HL7     ; Entry point for PBM processing - triggered by lab protocol
    18         ; LR7O ALL EVSEND RESULTS.
    19         ;
    20         N ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS
    21         ;
    22         ;  OREMSG is the pointer reference to the global that contains the
    23         ;  lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol.
    24         ; 
    25         I '$D(@OREMSG) Q
    26         ;
    27         ; Get Lab parameters
    28         ;
    29         D INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL)
    30         ;
    31         ; Set up CS delimeter for the Pharmacy message
    32         ;
    33         S PSUHL("CS")=$E(PSUHL("ECH"),1)
    34         ;
    35         ; Set up segment processing parameters
    36         ;
    37         S PSUEXT("PSUBUF")=$NA(^TMP("HLS",$J))
    38         S PSUEXT("PSUPTR")=0
    39         ;
    40         ; Get the delimiters that the passed in lab data is using
    41         ;
    42         D PARAMS
    43         S PSUHLECH=$G(ARR("PSUHLECH"),"^~\&")
    44         S PSUHLCS=$E(PSUHLECH,1)
    45         ;
    46         ; Quit if no DFN
    47         ;
    48         I '$D(ARR) Q
    49         I ARR("DFN")=0!(ARR("DFN")="") Q
    50         ;
    51         ; Quit if patient is an employee
    52         ;
    53         I $$EMPL^DGSEC4(ARR("DFN"),"PS") Q
    54         ;
    55         ; Get Lab's equivalent of a DFN (LRDFN)
    56         ;
    57         S LRDFN=$P(^DPT(ARR("DFN"),"LR"),"^")  ; DBIA 998 to get file #63 ien
    58         ;
    59         ; Loop through the lab data
    60         ;
    61         S FIRST=1
    62         D LOOP
    63         ;
    64         ; Generate an HL7 if data exists to be sent
    65         ;
    66         I 'FIRST D GENERATE
    67         ;
    68         K PSUHL,ERR,OPTNS,ERR
    69         ;
    70         Q
    71         ;
    72 LOOP    ;
    73         N CNT,LRIDT,LRSS,PREV1,PREV2,QUIT1,QUIT2,REC,REC1,REC2,SEG,SEG1,SEG2,STR1
    74         K ^TMP("HLS",$J)
    75         S CNT=0
    76         F  Q:CNT=""  S CNT=$O(@OREMSG@(CNT)) Q:'CNT  D
    77         . S REC=@OREMSG@(CNT)
    78         . S REC=$$STRING(REC,CNT)
    79         . S SEG=$P(REC,PSUHLFS,1)
    80         . I SEG'="ORC" Q
    81         . S STR1=$P(REC,PSUHLFS,4)
    82         . S STR1=$P(STR1,PSUHLCS,1)
    83         . S LRSS=$P(STR1,";",4)
    84         . ;
    85         . ; Quit if data is not for Chemistry
    86         . ;
    87         . I LRSS'="CH" Q
    88         . S LRIDT=$P(STR1,";",5)
    89         . S QUIT1=0
    90         . F  Q:QUIT1!(CNT="")  S PREV1=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT  D
    91         . . S REC1=@OREMSG@(CNT)
    92         . . S REC1=$$STRING(REC1,CNT)
    93         . . S SEG1=$P(REC1,PSUHLFS,1)
    94         . . I SEG1="ORC" S CNT=PREV1,QUIT1=1 Q
    95         . . I SEG1'="OBR" Q
    96         . . ; If this is the first OBR being processed i.e. this is valid
    97         . . ; chemistry data set the PID segment
    98         . . I FIRST D PID S FIRST=0
    99         . . D OBR(REC1)
    100         . . S QUIT2=0
    101         . . F  Q:QUIT2  S PREV2=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT  D
    102         . . . S REC2=@OREMSG@(CNT)
    103         . . . S REC2=$$STRING(REC2,CNT)
    104         . . . S SEG2=$P(REC2,PSUHLFS,1)
    105         . . . I SEG2="OBR"!(SEG2="ORC") S CNT=PREV2,QUIT2=1 Q
    106         . . . I SEG2'="OBX" Q
    107         . . . D OBX(REC2)
    108         Q
    109         ;
    110 PID     ;  Create the PID segment using the standard builder
    111         ;
    112         N K1,NEWSEG,SEG
    113         S SEG="SEG"
    114         D BLDPID^VAFCQRY(ARR("DFN"),1,"1,2,3",.SEG,.PSUHL,.ERR)
    115         ;
    116         ; Loop through the returned array just in case the data is spread over
    117         ; more than one node
    118         ;
    119         S K1="",NEWSEG=""
    120         F  S K1=$O(SEG(K1)) Q:'K1  D
    121         . S NEWSEG=NEWSEG_SEG(K1)
    122         ;
    123         ; Set the data string into the PBM HL7 array
    124         ;
    125         D SETSEG(NEWSEG)
    126         ;
    127         Q
    128         ;
    129 OBR(REC)        ;  Re-forms lab OBR to only send required data
    130         ;
    131         N OBRSEG,SITE,SPECDATE
    132         S OBRSEG="OBR"
    133         S SPECDATE=$P(REC,PSUHLFS,8)
    134         S SITE=$P(REC,PSUHLFS,16)
    135         S SITE=$TR(SITE,PSUHLCS,PSUHL("CS"))
    136         ;
    137         ; Create new OBR Segment and pass to SETSEG
    138         ;
    139         S $P(OBRSEG,PSUHL("FS"),8)=SPECDATE
    140         S $P(OBRSEG,PSUHL("FS"),16)=SITE
    141         ;
    142         ; Set the data string into the PBM HL7 array
    143         ;
    144         D SETSEG(OBRSEG)
    145         ;
    146         Q
    147         ;
    148 OBX(REC)        ;  Reforms lab OBX to only send the data needed
    149         N CODES,HRANGE,LABS,LNAME,LR60,LRANGE,LRDN,LOINC,LOINCS,P2,P3,P12,RANGE,RES,RESULTS,SEG,UNITS
    150         ;
    151         S P2=$P(REC,PSUHLFS,2)
    152         S P3=$P(REC,PSUHLFS,3)
    153         S P12=$P(REC,PSUHLFS,12)
    154         S RESULTS=$P(REC,PSUHLFS,6)
    155         S UNITS=$P(REC,PSUHLFS,7)
    156         S LABS=$P(REC,PSUHLFS,4)
    157         S LR60=$P(LABS,"^",4)
    158         I LR60']"" Q
    159         S LRDN=$G(^LAB(60,LR60,0))
    160         S LRDN=$P($P(LRDN,"^",5),";",2)   ;  DBIA 91 for data name
    161         ;
    162         ; Make the call to LRRPU to get the LOINC code for this test
    163         ;
    164         I LRDN']"" Q
    165         S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1)
    166         ;
    167         S CODES=$P(RES,U,8),LOINCS=$P(CODES,"!",3)
    168         S LOINC=$P(LOINCS,";",1),LNAME=$P(LOINCS,";",2)
    169         S LRANGE=$P(RES,U,3),HRANGE=$P(RES,U,4)
    170         S RANGE=LRANGE_"-"_HRANGE I RANGE="-" S RANGE=""
    171         ;
    172         ; Use the Pharmacy HL7 delimeters
    173         ;
    174         S LABS=$TR(LABS,PSUHLCS,PSUHL("CS"))
    175         ;
    176         ; Add LOINC to the list of Labs if it exists
    177         ;
    178         I LOINC'="" D
    179         . ;
    180         . ; Append the LOINC data using the pharmacy delimiters
    181         . S LABS=LABS_PSUHL("CS")_LOINC_PSUHL("CS")_LNAME_PSUHL("CS")_"99LN"
    182         ;
    183         ; Put the data in the string
    184         ;
    185         S SEG="OBX"
    186         S $P(SEG,PSUHL("FS"),2)=P2
    187         S $P(SEG,PSUHL("FS"),3)=P3
    188         S $P(SEG,PSUHL("FS"),4)=LABS
    189         S $P(SEG,PSUHL("FS"),6)=RESULTS
    190         S $P(SEG,PSUHL("FS"),7)=UNITS
    191         S $P(SEG,PSUHL("FS"),8)=RANGE
    192         S $P(SEG,PSUHL("FS"),12)=P12
    193         ;
    194         ; Put the string into the PBM HL7 global
    195         ;
    196         D SETSEG(SEG)
    197         ;
    198         Q
    199         ;
    200 STRING(HLSTR,CNT)       ;  Loops through sub nodes to create a full data string
    201         N J
    202         S J=""
    203         F  S J=$O(@OREMSG@(CNT,J))  Q:J=""  S HLSTR=HLSTR_@OREMSG@(CNT,J)
    204         Q HLSTR
    205         ;
    206 PARAMS  ; Get the delimiters used in the lab data
    207         ;
    208         N CNT,ID,QUIT,REC,RES
    209         K ARR
    210         S (QUIT,CNT)=0,RES=""
    211         F  S CNT=$O(@OREMSG@(CNT)) Q:'CNT!(QUIT=2)  D
    212         . S REC=@OREMSG@(CNT)
    213         . I $E(REC,1,3)="MSH" D  Q
    214         . . S PSUHLFS=$E(REC,4,4)
    215         . . S ARR("PSUHLECH")=$P(REC,PSUHLFS,2),QUIT=QUIT+1
    216         . I $P(REC,PSUHLFS,1)="PID" D  Q
    217         . . S ARR("DFN")=$P(REC,PSUHLFS,4)
    218         . . S QUIT=QUIT+1
    219         Q
    220         ;
    221 GENERATE        ; Generate HL7 message
    222         ;
    223         ; D GENERATE^HLMA("PSU-SITE-DRIVER","GM",1,.RESULT,"",.OPTNS)
    224         S OPTNS("QUEUE")="PBM LAB"
    225         S RESULT=$$EN^HLOCNRT("PSU-SITE-DRIVER","GM",.OPTNS)
    226         I +RESULT'=RESULT D
    227         . S ^XTMP("PBM/HLO",DT,$J)=RESULT
    228         K ^TMP("HLS",$J)
    229         Q
    230         ;
    231         ;
    232 SETSEG(SEG)     ;
    233         ;
    234         ;***** STORES THE SEGMENT INTO THE ^TMP("HLS",$J) BUFFER
    235         ;
    236         ; SEG           HL7 segment
    237         ;
    238         ; The SETSEG procedure stores the HL7 segment into the
    239         ; standard HL7 buffer ^TMP("HLS",$J). The <TAB>, <CR> and <LF>
    240         ; characters are replaced with spaces. Long segments are split among
    241         ; sub-nodes of the main segment node.
    242         ;
    243         ; The PSUEXT array must be initialized before
    244         ; calling this function.
    245         ;
    246         N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
    247         S NODE=PSUEXT("PSUBUF"),PTR=$G(PSUEXT("PSUPTR"))+1
    248         S SL=$L(SEG),MAXLEN=245  K @NODE@(PTR)
    249         ;--- Store the segment
    250         S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13),"   ")
    251         ;
    252         ;--- Split the segment into sub-nodes if necessary
    253         D:SL>MAXLEN
    254         . S I2=MAXLEN
    255         . F PTR1=1:1  S I1=I2+1,I2=I1+MAXLEN-1  Q:I1>SL  D
    256         . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13),"   ")
    257         ;--- Save the pointer
    258         S PSUEXT("PSUPTR")=PTR
    259         Q
     1PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 5/15/04 3:10pm
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3**;MARCH, 2005
     3 ;
     4 ; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol
     5 ; DBIA 998 to dig through ^DPT(i,"LR" go get the ien to file #63
     6 ; DBIA 91-A to dig through ^LAB(60 to get the name of the test
     7 ; DBIA 3630 to call the HL7 PID builder
     8 ; DBIA 4727 to call EN^HLOCNRT
     9 ; DBIA 3646 to call API: $$EMPL^DGSEC4
     10 ; DBIA 4658 to call API: $$TSTRES^LRRPU
     11 ;
     12 ; This program is called when a lab test is verified. If it is for a
     13 ; chemistry test, and not for an employee, an HL7 message will be
     14 ; created and sent to the CMOP-NAT server.
     15 ;
     16 ;
     17HL7 ; Entry point for PBM processing - triggered by lab protocol
     18 ; LR7O ALL EVSEND RESULTS.
     19 ;
     20 N ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS
     21 ;
     22 ;  OREMSG is the pointer reference to the global that contains the
     23 ;  lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol.
     24 ; 
     25 I '$D(@OREMSG) Q
     26 ;
     27 ; Get Lab parameters
     28 ;
     29 D INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL)
     30 ;
     31 ; Set up CS delimeter for the Pharmacy message
     32 ;
     33 S PSUHL("CS")=$E(PSUHL("ECH"),1)
     34 ;
     35 ; Set up segment processing parameters
     36 ;
     37 S PSUEXT("PSUBUF")=$NA(^TMP("HLS",$J))
     38 S PSUEXT("PSUPTR")=0
     39 ;
     40 ; Get the delimiters that the passed in lab data is using
     41 ;
     42 D PARAMS
     43 S PSUHLECH=$G(ARR("PSUHLECH"),"^~\&")
     44 S PSUHLCS=$E(PSUHLECH,1)
     45 ;
     46 ; Quit if no DFN
     47 ;
     48 I '$D(ARR) Q
     49 I ARR("DFN")=0!(ARR("DFN")="") Q
     50 ;
     51 ; Quit if patient is an employee
     52 ;
     53 I $$EMPL^DGSEC4(ARR("DFN"),"PS") Q
     54 ;
     55 ; Get Lab's equivalent of a DFN (LRDFN)
     56 ;
     57 S LRDFN=$P(^DPT(ARR("DFN"),"LR"),"^")  ; DBIA 998 to get file #63 ien
     58 ;
     59 ; Loop through the lab data
     60 ;
     61 S FIRST=1
     62 D LOOP
     63 ;
     64 ; Generate an HL7 if data exists to be sent
     65 ;
     66 I 'FIRST D GENERATE
     67 ;
     68 K PSUHL,ERR,OPTNS,ERR
     69 ;
     70 Q
     71 ;
     72LOOP ;
     73 N CNT,LRIDT,LRSS,PREV1,PREV2,QUIT1,QUIT2,REC,REC1,REC2,SEG,SEG1,SEG2,STR1
     74 K ^TMP("HLS",$J)
     75 S CNT=0
     76 F  Q:CNT=""  S CNT=$O(@OREMSG@(CNT)) Q:'CNT  D
     77 . S REC=@OREMSG@(CNT)
     78 . S REC=$$STRING(REC,CNT)
     79 . S SEG=$P(REC,PSUHLFS,1)
     80 . I SEG'="ORC" Q
     81 . S STR1=$P(REC,PSUHLFS,4)
     82 . S STR1=$P(STR1,PSUHLCS,1)
     83 . S LRSS=$P(STR1,";",4)
     84 . ;
     85 . ; Quit if data is not for Chemistry
     86 . ;
     87 . I LRSS'="CH" Q
     88 . S LRIDT=$P(STR1,";",5)
     89 . S QUIT1=0
     90 . F  Q:QUIT1!(CNT="")  S PREV1=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT  D
     91 . . S REC1=@OREMSG@(CNT)
     92 . . S REC1=$$STRING(REC1,CNT)
     93 . . S SEG1=$P(REC1,PSUHLFS,1)
     94 . . I SEG1="ORC" S CNT=PREV1,QUIT1=1 Q
     95 . . I SEG1'="OBR" Q
     96 . . ; If this is the first OBR being processed i.e. this is valid
     97 . . ; chemistry data set the PID segment
     98 . . I FIRST D PID S FIRST=0
     99 . . D OBR(REC1)
     100 . . S QUIT2=0
     101 . . F  Q:QUIT2  S PREV2=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT  D
     102 . . . S REC2=@OREMSG@(CNT)
     103 . . . S REC2=$$STRING(REC2,CNT)
     104 . . . S SEG2=$P(REC2,PSUHLFS,1)
     105 . . . I SEG2="OBR"!(SEG2="ORC") S CNT=PREV2,QUIT2=1 Q
     106 . . . I SEG2'="OBX" Q
     107 . . . D OBX(REC2)
     108 Q
     109 ;
     110PID ;  Create the PID segment using the standard builder
     111 ;
     112 N K1,NEWSEG,SEG
     113 S SEG="SEG"
     114 D BLDPID^VAFCQRY(ARR("DFN"),1,"1,2,3",.SEG,.PSUHL,.ERR)
     115 ;
     116 ; Loop through the returned array just in case the data is spread over
     117 ; more than one node
     118 ;
     119 S K1="",NEWSEG=""
     120 F  S K1=$O(SEG(K1)) Q:'K1  D
     121 . S NEWSEG=NEWSEG_SEG(K1)
     122 ;
     123 ; Set the data string into the PBM HL7 array
     124 ;
     125 D SETSEG(NEWSEG)
     126 ;
     127 Q
     128 ;
     129OBR(REC) ;  Re-forms lab OBR to only send required data
     130 ;
     131 N OBRSEG,SITE,SPECDATE
     132 S OBRSEG="OBR"
     133 S SPECDATE=$P(REC,PSUHLFS,8)
     134 S SITE=$P(REC,PSUHLFS,16)
     135 S SITE=$TR(SITE,PSUHLCS,PSUHL("CS"))
     136 ;
     137 ; Create new OBR Segment and pass to SETSEG
     138 ;
     139 S $P(OBRSEG,PSUHL("FS"),8)=SPECDATE
     140 S $P(OBRSEG,PSUHL("FS"),16)=SITE
     141 ;
     142 ; Set the data string into the PBM HL7 array
     143 ;
     144 D SETSEG(OBRSEG)
     145 ;
     146 Q
     147 ;
     148OBX(REC) ;  Reforms lab OBX to only send the data needed
     149 N CODES,HRANGE,LABS,LNAME,LR60,LRANGE,LRDN,LOINC,LOINCS,P2,P3,P12,RANGE,RES,RESULTS,SEG,UNITS
     150 ;
     151 S P2=$P(REC,PSUHLFS,2)
     152 S P3=$P(REC,PSUHLFS,3)
     153 S P12=$P(REC,PSUHLFS,12)
     154 S RESULTS=$P(REC,PSUHLFS,6)
     155 S UNITS=$P(REC,PSUHLFS,7)
     156 S LABS=$P(REC,PSUHLFS,4)
     157 S LR60=$P(LABS,"^",4)
     158 S LRDN=$G(^LAB(60,LR60,0))
     159 S LRDN=$P($P(LRDN,"^",5),";",2)   ;  DBIA 91 for data name
     160 ;
     161 ; Make the call to LRRPU to get the LOINC code for this test
     162 ;
     163 S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1)
     164 ;
     165 S CODES=$P(RES,U,8),LOINCS=$P(CODES,"!",3)
     166 S LOINC=$P(LOINCS,";",1),LNAME=$P(LOINCS,";",2)
     167 S LRANGE=$P(RES,U,3),HRANGE=$P(RES,U,4)
     168 S RANGE=LRANGE_"-"_HRANGE I RANGE="-" S RANGE=""
     169 ;
     170 ; Use the Pharmacy HL7 delimeters
     171 ;
     172 S LABS=$TR(LABS,PSUHLCS,PSUHL("CS"))
     173 ;
     174 ; Add LOINC to the list of Labs if it exists
     175 ;
     176 I LOINC'="" D
     177 . ;
     178 . ; Append the LOINC data using the pharmacy delimiters
     179 . S LABS=LABS_PSUHL("CS")_LOINC_PSUHL("CS")_LNAME_PSUHL("CS")_"99LN"
     180 ;
     181 ; Put the data in the string
     182 ;
     183 S SEG="OBX"
     184 S $P(SEG,PSUHL("FS"),2)=P2
     185 S $P(SEG,PSUHL("FS"),3)=P3
     186 S $P(SEG,PSUHL("FS"),4)=LABS
     187 S $P(SEG,PSUHL("FS"),6)=RESULTS
     188 S $P(SEG,PSUHL("FS"),7)=UNITS
     189 S $P(SEG,PSUHL("FS"),8)=RANGE
     190 S $P(SEG,PSUHL("FS"),12)=P12
     191 ;
     192 ; Put the string into the PBM HL7 global
     193 ;
     194 D SETSEG(SEG)
     195 ;
     196 Q
     197 ;
     198STRING(HLSTR,CNT) ;  Loops through sub nodes to create a full data string
     199 N J
     200 S J=""
     201 F  S J=$O(@OREMSG@(CNT,J))  Q:J=""  S HLSTR=HLSTR_@OREMSG@(CNT,J)
     202 Q HLSTR
     203 ;
     204PARAMS ; Get the delimiters used in the lab data
     205 ;
     206 N CNT,ID,QUIT,REC,RES
     207 K ARR
     208 S (QUIT,CNT)=0,RES=""
     209 F  S CNT=$O(@OREMSG@(CNT)) Q:'CNT!(QUIT=2)  D
     210 . S REC=@OREMSG@(CNT)
     211 . I $E(REC,1,3)="MSH" D  Q
     212 . . S PSUHLFS=$E(REC,4,4)
     213 . . S ARR("PSUHLECH")=$P(REC,PSUHLFS,2),QUIT=QUIT+1
     214 . I $P(REC,PSUHLFS,1)="PID" D  Q
     215 . . S ARR("DFN")=$P(REC,PSUHLFS,4)
     216 . . S QUIT=QUIT+1
     217 Q
     218 ;
     219GENERATE ; Generate HL7 message
     220 ;
     221 ; D GENERATE^HLMA("PSU-SITE-DRIVER","GM",1,.RESULT,"",.OPTNS)
     222 S OPTNS("QUEUE")="PBM LAB"
     223 S RESULT=$$EN^HLOCNRT("PSU-SITE-DRIVER","GM",.OPTNS)
     224 I +RESULT'=RESULT D
     225 . S ^XTMP("PBM/HLO",DT,$J)=RESULT
     226 K ^TMP("HLS",$J)
     227 Q
     228 ;
     229 ;
     230SETSEG(SEG) ;
     231 ;
     232 ;***** STORES THE SEGMENT INTO THE ^TMP("HLS",$J) BUFFER
     233 ;
     234 ; SEG           HL7 segment
     235 ;
     236 ; The SETSEG procedure stores the HL7 segment into the
     237 ; standard HL7 buffer ^TMP("HLS",$J). The <TAB>, <CR> and <LF>
     238 ; characters are replaced with spaces. Long segments are split among
     239 ; sub-nodes of the main segment node.
     240 ;
     241 ; The PSUEXT array must be initialized before
     242 ; calling this function.
     243 ;
     244 N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
     245 S NODE=PSUEXT("PSUBUF"),PTR=$G(PSUEXT("PSUPTR"))+1
     246 S SL=$L(SEG),MAXLEN=245  K @NODE@(PTR)
     247 ;--- Store the segment
     248 S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13),"   ")
     249 ;
     250 ;--- Split the segment into sub-nodes if necessary
     251 D:SL>MAXLEN
     252 . S I2=MAXLEN
     253 . F PTR1=1:1  S I1=I2+1,I2=I1+MAXLEN-1  Q:I1>SL  D
     254 . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13),"   ")
     255 ;--- Save the pointer
     256 S PSUEXT("PSUPTR")=PTR
     257 Q
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m

    r613 r623  
    1 PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 4/12/07 2:12pm
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
    3         ;
    4         ;DBIA's
    5         ;Reference to file (#59.7) supported by DBIA 2854
    6         ;
    7 EN      ; select Editing or Report of Mapping
    8         W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!!
    9         ;
    10 MODP    ; module selection prompt
    11         W !!,?5,"This option allows the mapping of dispensing/procurement locations"
    12         W !,?5,"from the AR/WS, Controlled Substances, and Drug Accountability"
    13         W !,?5,"applications to either a Medical Center Division or an Outpatient Site."
    14         W !,?5,"Any dispensing/procurement data associated with an AR/WS AOU, CS NAOU"
    15         W !,?5,"or DA Pharmacy Location that has not been mapped will be attributed to"
    16         W !,?5,"to the facility at which the database resides.  Any unmapped locations"
    17         W !,?5,"will be displayed upon entering the option.",!
    18         ;
    19         D EN1^PSUMAPR ;scan and report unmapped locations
    20         W @IOF
    21         ;
    22 MODULE  ;
    23         W !!,"Select the dispensing/procurement location to map:",!
    24         S PSUA(1)="1.  AR/WS Area of Use (AOU)"
    25         S PSUA(2)="2.  Controlled Substances (CS) Narcotic Area of Use (NAOU)"
    26         S PSUA(3)="3.  Drug Accountability (DA) Pharmacy location"
    27         S PSUA(4)="4.  Print Report of Mapped/Unmapped Locations"
    28         F I=1:1:4 W !,?10,PSUA(I)
    29         W !!,?2,"You may select all by entering 'A' for ALL or by using '1:4'.",!
    30         W !,?2,"Select the dispensing/procurement location: "
    31         R X:DTIME E  W !!,"Nothing Selected - Exiting",! H 3 G EXIT
    32         I X["^" G EXIT:X="^"
    33         I X="" W "  <??>",$C(7) S X="?"
    34         ;
    35         S:"Aa"[$E(X) X="1:4"
    36 MODHLP  I X["?" D  G MODULE
    37         .W !!,"Enter:  A single number to edit (or print) that selection."
    38         .W !,?8,"A range of code numbers.  Example:  1:3"
    39         .W !,?8,"Multiple code numbers separated by commas.  Example:  1,3"
    40         .W !,?8,"The letter A to select ALL items."
    41         .W !,?8,"A single up-arrow ( ^ ) to exit now without any action."
    42         S X=$TR(X,"-;_><.A","::::::")
    43         K PSUMOD
    44         F PII=1:1:$L(X,",") D
    45         .S X1=$P(X,",",PII)
    46         .Q:X1=""
    47         .I X1[":" D  Q
    48         ..S XBEG=$P(X1,":",1),XEND=$P(X1,":",2)
    49         ..I (XBEG="")!(XEND="") Q
    50         ..F PJJ=XBEG:1:XEND S PSUMOD(PJJ)=""
    51         ..K PJJ,XBEG,XEND
    52         .S PSUMOD(X1)=""
    53         ; modified to fix <UNDEFINED> PSU*3*12 BAJ
    54         S X="",ERC=0 F  S X=$O(PSUMOD(X)) Q:X=""  I '$D(PSUA(X)) S ERC=1 Q
    55         I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP
    56         I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT
    57         ;
    58         ;
    59         W !!,"You have selected: "
    60         S X="",PSUOPTS="" F  S X=$O(PSUMOD(X)) Q:X=""  W !,?10,PSUA(X)
    61         W ! K DIR S DIR(0)="E" D ^DIR G:'Y EXIT
    62         I $D(PSUMOD(4)) D REPORT K PSUA(4)
    63         I $D(PSUMOD(1)) D E9001
    64         I $D(PSUMOD(2)) D E9002
    65         I $D(PSUMOD(3)) D E9003
    66         Q
    67 E9001   ;EDIT 90.01 AR/WS AOU MAPPING
    68         W @IOF,!!,?20,"EDITING Mapping of AR/WS AOUs",!!
    69         K DIC,DA,DIE
    70         K Z,ZZ,IENS
    71         S DA(1)=1
    72         S DIC="^PS(59.7,1,90.01,",DA(1)=1,DIC(0)="ACEQML"
    73         S DIC("W")="X XX1,XX2"
    74         S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79001,IENS,.02),ZZ=$$GET1^DIQ(59.79001,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP:  "",ZZ"
    75         S XX2="S ZZ=$$GET1^DIQ(58.1,+Y,3,""I"") W:ZZ ?65,""**INACTIVE**"""
    76         D ^DIC
    77         Q:Y'>0
    78         S DA=+Y,DIE=DIC
    79         S ZZ=^PS(59.7,1,90.01,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
    80         I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
    81         E  S DR=".01;.02;S:X'="""" Y=0;.03"
    82         D ^DIE W !
    83         G E9001
    84         ;
    85 CHK1    ;check that AOUs are mapped
    86         K IENS
    87         S DA=0,DA(1)=1 F  S DA=$O(^PS(59.7,1,90.01,DA)) Q:DA'>0  D
    88         . S Z=^PS(59.7,1,90.01,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
    89         . I Y,'X Q
    90         . I 'Y,X Q
    91         . S IENS=DA_",1" W !,?3,"AR/WS AOU",?15,$$GET1^DIQ(59.79001,IENS,.01),?25," is not mapped."
    92         I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1
    93         Q
    94         ;
    95 E9002   ;EDIT 90.02 CS NAOU MAPPING
    96         W @IOF,!!,?20,"EDITING Mapping of CS NAOUs",!!
    97         K DIC,DA,DIE
    98         K Z,ZZ,IENS
    99         S DA(1)=1
    100         S DIC="^PS(59.7,DA(1),90.02,",DIC(0)="AEQMLCZ"
    101         S DIC("W")="X XX1,XX2"
    102         S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79002,IENS,.02),ZZ=$$GET1^DIQ(59.79002,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP:  "",ZZ"
    103         S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """
    104         D ^DIC
    105         Q:Y'>0
    106         S DA=+Y,DIE=DIC
    107         S ZZ=^PS(59.7,1,90.02,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
    108         I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
    109         E  S DR=".01;.02;S:X'="""" Y=0;.03"
    110         D ^DIE W !
    111         G E9002
    112         ;
    113 CHK2    ;check that NAOUs are mapped
    114         K IENS
    115         S DA=0,DA(1)=1 F  S DA=$O(^PS(59.7,1,90.02,DA)) Q:DA'>0  D
    116         . S Z=^PS(59.7,1,90.02,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
    117         . I Y,'X Q
    118         . I 'Y,X Q
    119         . S IENS=DA_",1" W !,?3,"CS NAOU",?15,$$GET1^DIQ(59.79002,IENS,.01),?25," is not mapped."
    120         Q
    121 E9003   ;EDIT 90.03 DRUG ACCOUNTABILITY LOCATION MAPPING
    122         W @IOF,!!,?20,"EDITING Mapping of DA Pharmacy Locations",!!
    123         K DIC,DA,DIE
    124         K Z,ZZ,IENS
    125         S DA(1)=1
    126         S DIC="^PS(59.7,DA(1),90.03,",DIC(0)="AEQMLZ"
    127         S DIC("W")="X XX1,XX2"
    128         S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79003,IENS,.02),ZZ=$$GET1^DIQ(59.79003,IENS,.03) W:$L(Z) ?35,"" Div: "",Z W:$L(ZZ) ?35,""OP:  "",ZZ"
    129         S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """
    130         D ^DIC
    131         Q:Y'>0
    132         S DA=+Y,DIE=DIC
    133         S ZZ=^PS(59.7,1,90.03,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
    134         I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
    135         E  S DR=".01;.02;S:X'="""" Y=0;.03"
    136         D ^DIE W !
    137         G E9003
    138         ;
    139 CHK3    ;check that DRUG ACCOUNTABILITY LOCATIONs are mapped
    140         K IENS
    141         S DA=0,DA(1)=1 F  S DA=$O(^PS(59.7,1,90.03,DA)) Q:DA'>0  D
    142         . S Z=^PS(59.7,1,90.03,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
    143         . I Y,'X Q
    144         . I 'Y,X Q
    145         . S IENS=DA_",1" W !,?3,"DA Phar Loc",?15,$$GET1^DIQ(59.79003,IENS,.01),?25," is not mapped."
    146         I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1
    147         Q
    148 REPORT  ;Print Mapping Report
    149         W @IOF,!,"Print Pharmacy Location PBM Extract Mapping Report",!
    150         S %ZIS="Q" D ^%ZIS
    151         Q:POP
    152         I $D(IO("Q")) D QUEUE Q
    153         D EN^PSUMAPR
    154         Q
    155 QUEUE   S ZTRTN="EN^PSUMAPR",ZTDESC="PRINT REPORT OF PBM EXTRACT MAPPING"
    156         S ZTREQ="@" D ^%ZTLOAD
    157         W !,"TASKED with ",$G(ZTSK) I '$G(ZTSK) W ">> DID NOT Task !!",! H 3
    158         Q
    159 EXIT    ;
    160         Q
     1PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 9SEP2003
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;
     4 ;DBIA's
     5 ;Reference to file (#59.7) supported by DBIA 2854
     6 ;
     7EN ; select Editing or Report of Mapping
     8 W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!!
     9 ;
     10MODP ; module selection prompt
     11 W !!,?5,"This option allows the mapping of dispensing/procurement locations"
     12 W !,?5,"from the AR/WS, Controlled Substances, and Drug Accountability"
     13 W !,?5,"applications to either a Medical Center Division or an Outpatient Site."
     14 W !,?5,"Any dispensing/procurement data associated with an AR/WS AOU, CS NAOU"
     15 W !,?5,"or DA Pharmacy Location that has not been mapped will be attributed to"
     16 W !,?5,"to the facility at which the database resides.  Any unmapped locations"
     17 W !,?5,"will be displayed upon entering the option.",!
     18 ;
     19 D EN1^PSUMAPR ;scan and report unmapped locations
     20 W @IOF
     21 ;
     22MODULE ;
     23 W !!,"Select the dispensing/procurement location to map:",!
     24 S PSUA(1)="1.  AR/WS Area of Use (AOU)"
     25 S PSUA(2)="2.  Controlled Substances (CS) Narcotic Area of Use (NAOU)"
     26 S PSUA(3)="3.  Drug Accountability (DA) Pharmacy location"
     27 S PSUA(4)="4.  Print Report of Mapped/Unmapped Locations"
     28 F I=1:1:4 W !,?10,PSUA(I)
     29 W !!,?2,"You may select all by entering 'A' for ALL or by using '1:4'.",!
     30 W !,?2,"Select the dispensing/procurement location: "
     31 R X:DTIME E  W !!,"Nothing Selected - Exiting",! H 3 G EXIT
     32 I X["^" G EXIT:X="^"
     33 I X="" W "  <??>",$C(7) S X="?"
     34 ;
     35 S:"Aa"[$E(X) X="1:4"
     36MODHLP I X["?" D  G MODULE
     37 .W !!,"Enter:  A single number to edit (or print) that selection."
     38 .W !,?8,"A range of code numbers.  Example:  1:3"
     39 .W !,?8,"Multiple code numbers separated by commas.  Example:  1,3"
     40 .W !,?8,"The letter A to select ALL items."
     41 .W !,?8,"A single up-arrow ( ^ ) to exit now without any action."
     42 S X=$TR(X,"-;_><.A","::::::")
     43 K PSUMOD
     44 F PII=1:1:$L(X,",") D
     45 .S X1=$P(X,",",PII)
     46 .Q:X1=""
     47 .I X1[":" D  Q
     48 ..S XBEG=$P(X1,":",1),XEND=$P(X1,":",2)
     49 ..I (XBEG="")!(XEND="") Q
     50 ..F PJJ=XBEG:1:XEND S PSUMOD(PJJ)=""
     51 ..K PJJ,XBEG,XEND
     52 .S PSUMOD(X1)=""
     53 S (X,ERC)=0 F  S X=$O(PSUMOD(X)) Q:X=""  I '$D(PSUA(X)) S ERC=1 Q
     54 I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP
     55 I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT
     56 ;
     57 ;
     58 W !!,"You have selected: "
     59 S X="",PSUOPTS="" F  S X=$O(PSUMOD(X)) Q:X=""  W !,?10,PSUA(X)
     60 W ! K DIR S DIR(0)="E" D ^DIR G:'Y EXIT
     61 I $D(PSUMOD(4)) D REPORT K PSUA(4)
     62 I $D(PSUMOD(1)) D E9001
     63 I $D(PSUMOD(2)) D E9002
     64 I $D(PSUMOD(3)) D E9003
     65 Q
     66E9001 ;EDIT 90.01 AR/WS AOU MAPPING
     67 W @IOF,!!,?20,"EDITING Mapping of AR/WS AOUs",!!
     68 K DIC,DA,DIE
     69 K Z,ZZ,IENS
     70 S DA(1)=1
     71 S DIC="^PS(59.7,1,90.01,",DA(1)=1,DIC(0)="ACEQML"
     72 S DIC("W")="X XX1,XX2"
     73 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79001,IENS,.02),ZZ=$$GET1^DIQ(59.79001,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP:  "",ZZ"
     74 S XX2="S ZZ=$$GET1^DIQ(58.1,+Y,3,""I"") W:ZZ ?65,""**INACTIVE**"""
     75 D ^DIC
     76 Q:Y'>0
     77 S DA=+Y,DIE=DIC
     78 S ZZ=^PS(59.7,1,90.01,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
     79 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
     80 E  S DR=".01;.02;S:X'="""" Y=0;.03"
     81 D ^DIE W !
     82 G E9001
     83 ;
     84CHK1 ;check that AOUs are mapped
     85 K IENS
     86 S DA=0,DA(1)=1 F  S DA=$O(^PS(59.7,1,90.01,DA)) Q:DA'>0  D
     87 . S Z=^PS(59.7,1,90.01,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
     88 . I Y,'X Q
     89 . I 'Y,X Q
     90 . S IENS=DA_",1" W !,?3,"AR/WS AOU",?15,$$GET1^DIQ(59.79001,IENS,.01),?25," is not mapped."
     91 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1
     92 Q
     93 ;
     94E9002 ;EDIT 90.02 CS NAOU MAPPING
     95 W @IOF,!!,?20,"EDITING Mapping of CS NAOUs",!!
     96 K DIC,DA,DIE
     97 K Z,ZZ,IENS
     98 S DA(1)=1
     99 S DIC="^PS(59.7,DA(1),90.02,",DIC(0)="AEQMLCZ"
     100 S DIC("W")="X XX1,XX2"
     101 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79002,IENS,.02),ZZ=$$GET1^DIQ(59.79002,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP:  "",ZZ"
     102 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """
     103 D ^DIC
     104 Q:Y'>0
     105 S DA=+Y,DIE=DIC
     106 S ZZ=^PS(59.7,1,90.02,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
     107 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
     108 E  S DR=".01;.02;S:X'="""" Y=0;.03"
     109 D ^DIE W !
     110 G E9002
     111 ;
     112CHK2 ;check that NAOUs are mapped
     113 K IENS
     114 S DA=0,DA(1)=1 F  S DA=$O(^PS(59.7,1,90.02,DA)) Q:DA'>0  D
     115 . S Z=^PS(59.7,1,90.02,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
     116 . I Y,'X Q
     117 . I 'Y,X Q
     118 . S IENS=DA_",1" W !,?3,"CS NAOU",?15,$$GET1^DIQ(59.79002,IENS,.01),?25," is not mapped."
     119 Q
     120E9003 ;EDIT 90.03 DRUG ACCOUNTABILITY LOCATION MAPPING
     121 W @IOF,!!,?20,"EDITING Mapping of DA Pharmacy Locations",!!
     122 K DIC,DA,DIE
     123 K Z,ZZ,IENS
     124 S DA(1)=1
     125 S DIC="^PS(59.7,DA(1),90.03,",DIC(0)="AEQMLZ"
     126 S DIC("W")="X XX1,XX2"
     127 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79003,IENS,.02),ZZ=$$GET1^DIQ(59.79003,IENS,.03) W:$L(Z) ?35,"" Div: "",Z W:$L(ZZ) ?35,""OP:  "",ZZ"
     128 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """
     129 D ^DIC
     130 Q:Y'>0
     131 S DA=+Y,DIE=DIC
     132 S ZZ=^PS(59.7,1,90.03,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
     133 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
     134 E  S DR=".01;.02;S:X'="""" Y=0;.03"
     135 D ^DIE W !
     136 G E9003
     137 ;
     138CHK3 ;check that DRUG ACCOUNTABILITY LOCATIONs are mapped
     139 K IENS
     140 S DA=0,DA(1)=1 F  S DA=$O(^PS(59.7,1,90.03,DA)) Q:DA'>0  D
     141 . S Z=^PS(59.7,1,90.03,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
     142 . I Y,'X Q
     143 . I 'Y,X Q
     144 . S IENS=DA_",1" W !,?3,"DA Phar Loc",?15,$$GET1^DIQ(59.79003,IENS,.01),?25," is not mapped."
     145 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1
     146 Q
     147REPORT ;Print Mapping Report
     148 W @IOF,!,"Print Pharmacy Location PBM Extract Mapping Report",!
     149 S %ZIS="Q" D ^%ZIS
     150 Q:POP
     151 I $D(IO("Q")) D QUEUE Q
     152 D EN^PSUMAPR
     153 Q
     154QUEUE S ZTRTN="EN^PSUMAPR",ZTDESC="PRINT REPORT OF PBM EXTRACT MAPPING"
     155 S ZTREQ="@" D ^%ZTLOAD
     156 W !,"TASKED with ",$G(ZTSK) I '$G(ZTSK) W ">> DID NOT Task !!",! H 3
     157 Q
     158EXIT ;
     159 Q
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOPAM.m

    r613 r623  
    1 PSUOPAM ;BIR/DAM - PSU PBM Outpatient AMIS Pharmacy Data Collection; March 2004 ; 1/11/08 11:46am
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3
    3         ;
    4         ;DBIA's
    5         ;Reference to File (#52)     supported by DBIA 1878
    6         ;
    7 EN      ;entry point to gather additional AMIS data.  Called from PSUOP2
    8         ;
    9         K PSUAM      ;Array to hold single dose Medication Instructions
    10         K PSUAMMD    ;Array to hold multidose medication instructions
    11         K PSUMDFLG   ;Multidose flag
    12         S (PSUPI,PSUCO,PSUEXP,PSUAM,PSUDSG,PSUDIPU,PSUNITS,PSUNOUN)=""
    13         S (PSUDUR,PSUCONJ,PSUROUT,PSUSCHED,PSUVERB)=""
    14         D CO
    15         D EXP
    16         D DOSG
    17         Q
    18         ;
    19         ;
    20 CO      ;Copay status: found in file (#52), field (#105)
    21         ;
    22         ;PSU*4*13 Corrected to show the COPAY.
    23         S PSUCO=$P($G(^TMP("PSOR",$J,PSURXIEN,"IB")),U,1)
    24         I $G(PSUCO) S PSUCOPAY="Y"
    25         I '$G(PSUCO) S PSUCOPAY="N"
    26         Q
    27         ;
    28 EXP     ;Expanded instructions: found in file (#52), multiple (#113),
    29         ;sub-field (#.01)
    30         ;
    31         S PSUD1=0
    32         F  S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1)) Q:PSUD1=""  D
    33         .I PSUD1=1 S PSUEXP=$E(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80) D
    34         ..S PSUPI=$G(PSUEXP)
    35         .I (PSUD1'=1),($L(PSUEXP)<80) D
    36         ..S PSUEXP=$E(PSUEXP_" "_^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80)
    37         ..S PSUPI=$G(PSUEXP)
    38         ;
    39         Q
    40         ;
    41 DOSG    ;Dosage data: found in file (#52), multiple (#113).  There are
    42         ;nine sub-fields to be pulled: #.01 through #8
    43         ;
    44         S PSUD1=0
    45         F  S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1)) Q:PSUD1=""  D
    46         .I PSUD1'=1 S PSUMDFLG="M"       ;Multidose flag
    47         .I PSUD1=1 D                     ;Single dose/first Multidose data
    48         ..S PSUAM=^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1,0)
    49         ..S PSUDSG=$P(PSUAM,U,1)             ;Dosage Ordered
    50         ..S PSUDISPU=$P(PSUAM,U,2)           ;Dispense Units per Dose
    51         ..S PSUNITS=$P($P(PSUAM,U,3),";",2)  ;Units
    52         ..S PSUNOUN=$P(PSUAM,U,4)            ;Noun
    53         ..S PSUDUR=$P(PSUAM,U,5)             ;Duration
    54         ..S PSUCONJ=$P(PSUAM,U,6)            ;Conjunction
    55         ..S PSUROUT=$P($P(PSUAM,U,7),";",2)  ;Route
    56         ..S PSUSCHED=$P(PSUAM,U,8)           ;Schedule
    57         ..S PSUVERB=$P(PSUAM,U,9)            ;Verb
    58         ;
    59         Q
    60         ;
    61 MULTI   ;Set variables for Multidose Medication Instructions
    62         ;Called from PSUOP3
    63         ;
    64         S (PSUDSGMD,PSUDSPMD,PSUNITMD,PSUNMD)=""
    65         S (PSURTMD,PSUSCHMD,PSUVRBMD)=""
    66         ;
    67         S PSUDSGMD=$P(PSUAMMD,U,1)            ;Dosage Ordered
    68         S PSUDSPMD=$P(PSUAMMD,U,2)            ;Dispense Units per Dose
    69         S PSUNITMD=$P($P(PSUAMMD,U,3),";",2)  ;Units
    70         S PSUNMD=$P(PSUAMMD,U,4)              ;Noun
    71         S PSUDURMD=$P(PSUAMMD,U,5)            ;Duration
    72         S PSUCONMD=$P(PSUAMMD,U,6)            ;Conjunction
    73         S PSURTMD=$P($P(PSUAMMD,U,7),";",2)   ;Route
    74         S PSUSCHMD=$P(PSUAMMD,U,8)            ;Schedule
    75         S PSUVRBMD=$P(PSUAMMD,U,9)            ;Verb
    76         ;
    77         Q
     1PSUOPAM ;BIR/DAM - PSU PBM Outpatient AMIS Pharmacy Data Collection; March 2004
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;
     4 ;DBIA's
     5 ;Reference to File (#52)     supported by DBIA 1878
     6 ;
     7EN ;entry point to gather additional AMIS data.  Called from PSUOP2
     8 ;
     9 K PSUAM      ;Array to hold single dose Medication Instructions
     10 K PSUAMMD    ;Array to hold multidose medication instructions
     11 K PSUMDFLG   ;Multidose flag
     12 S (PSUPI,PSUCO,PSUEXP,PSUAM,PSUDSG,PSUDIPU,PSUNITS,PSUNOUN)=""
     13 S (PSUDUR,PSUCONJ,PSUROUT,PSUSCHED,PSUVERB)=""
     14 D CO
     15 D EXP
     16 D DOSG
     17 Q
     18 ;
     19 ;
     20CO ;Copay status: found in file (#52), field (#105)
     21 ;
     22 S PSUCO=$P($G(^TMP("PSOR",$J,PSURXIEN,"IB",0)),U,1)
     23 I $G(PSUCO) S PSUCOPAY="Y"
     24 I '$G(PSUCO) S PSUCOPAY="N"
     25 Q
     26 ;
     27EXP ;Expanded instructions: found in file (#52), multiple (#113),
     28 ;sub-field (#.01)
     29 ;
     30 S PSUD1=0
     31 F  S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1)) Q:PSUD1=""  D
     32 .I PSUD1=1 S PSUEXP=$E(^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80) D
     33 ..S PSUPI=$G(PSUEXP)
     34 .I (PSUD1'=1),($L(PSUEXP)<80) D
     35 ..S PSUEXP=$E(PSUEXP_" "_^TMP("PSOR",$J,PSURXIEN,"PI",PSUD1,0),1,80)
     36 ..S PSUPI=$G(PSUEXP)
     37 ;
     38 Q
     39 ;
     40DOSG ;Dosage data: found in file (#52), multiple (#113).  There are
     41 ;nine sub-fields to be pulled: #.01 through #8
     42 ;
     43 S PSUD1=0
     44 F  S PSUD1=$O(^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1)) Q:PSUD1=""  D
     45 .I PSUD1'=1 S PSUMDFLG="M"       ;Multidose flag
     46 .I PSUD1=1 D                     ;Single dose/first Multidose data
     47 ..S PSUAM=^TMP("PSOR",$J,PSURXIEN,"MI",PSUD1,0)
     48 ..S PSUDSG=$P(PSUAM,U,1)             ;Dosage Ordered
     49 ..S PSUDISPU=$P(PSUAM,U,2)           ;Dispense Units per Dose
     50 ..S PSUNITS=$P($P(PSUAM,U,3),";",2)  ;Units
     51 ..S PSUNOUN=$P(PSUAM,U,4)            ;Noun
     52 ..S PSUDUR=$P(PSUAM,U,5)             ;Duration
     53 ..S PSUCONJ=$P(PSUAM,U,6)            ;Conjunction
     54 ..S PSUROUT=$P($P(PSUAM,U,7),";",2)  ;Route
     55 ..S PSUSCHED=$P(PSUAM,U,8)           ;Schedule
     56 ..S PSUVERB=$P(PSUAM,U,9)            ;Verb
     57 ;
     58 Q
     59 ;
     60MULTI ;Set variables for Multidose Medication Instructions
     61 ;Called from PSUOP3
     62 ;
     63 S (PSUDSGMD,PSUDSPMD,PSUNITMD,PSUNMD)=""
     64 S (PSURTMD,PSUSCHMD,PSUVRBMD)=""
     65 ;
     66 S PSUDSGMD=$P(PSUAMMD,U,1)            ;Dosage Ordered
     67 S PSUDSPMD=$P(PSUAMMD,U,2)            ;Dispense Units per Dose
     68 S PSUNITMD=$P($P(PSUAMMD,U,3),";",2)  ;Units
     69 S PSUNMD=$P(PSUAMMD,U,4)              ;Noun
     70 S PSUDURMD=$P(PSUAMMD,U,5)            ;Duration
     71 S PSUCONMD=$P(PSUAMMD,U,6)            ;Conjunction
     72 S PSURTMD=$P($P(PSUAMMD,U,7),";",2)   ;Route
     73 S PSUSCHMD=$P(PSUAMMD,U,8)            ;Schedule
     74 S PSUVRBMD=$P(PSUAMMD,U,9)            ;Verb
     75 ;
     76 Q
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m

    r613 r623  
    1 PSUPR2  ;BIR/PDW - Procurement extract from file 58.811 ; 4/1/08 4:09pm
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3
    3         ;DBIAs
    4         ; Reference to file #58.811 supported by DBIA 2521
    5         ; Reference to file #51.5   supported by DBIA 1931
    6         ; Reference to file #50     supported by DBIA 221
    7         ; Reference to file #58.8   supported by DBIA 2519
    8         ; Reference to file #42     supported by DBIA 2440
    9         ; Reference to file #40.8   supported by DBIA 2438
    10         ; Reference to file #59.5   supported by DBIA 2499
    11         ; Reference to file #59     supported by DBIA 2510
    12         ;
    13 EN      ;
    14         S PSUEND=PSUEDT
    15         S PSUEDT=PSUEDT\1+.24
    16         S:'$D(PSUPRJOB) PSUPRJOB=$J
    17         S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J
    18         I '$D(^XTMP(PSUPRSUB)) D
    19         . S ^XTMP(PSUPRSUB,"RECORDS",0)=""
    20         . S X1=DT,X2=6 D C^%DTC
    21         . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
    22         ;
    23         S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
    24         D MAP
    25         ;
    26         ;   check for Drug Accountability
    27         S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY")
    28         I 'X Q  ; not installed
    29         ;
    30         S X1=PSUSDT,X2=-45 ;backup by 45 days per revision
    31         D C^%DTC
    32         S PSUDT=X
    33         ;    loop thru invoice date field xref
    34         F  S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT  Q:PSUDT'>0  D
    35         .  S PSUORDA=0 F  S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0  D
    36         .. S PSUINVDA=0 F  S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0  D INVOICE
    37         Q
    38         ;
    39 INVOICE ;EP process an invoice within an order
    40         N PSUSTAT
    41         S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2)
    42         I PSUSTAT'="C" Q  ;     3.2.6.1
    43         N PSUORD
    44         D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD")
    45         ;
    46         S PSUINV=""
    47         N PSURDT,PSUIVNUM
    48         D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I")
    49         D MOVEI^PSUTL("PSUINV")
    50         S PSURDT=PSUINV(8)
    51         S PSUIVNUM=PSUINV(.01)
    52         ;
    53         I $G(PSUINV(4)) D DIV
    54         I $L(PSUDIV) S PSUDIVI=""
    55         E  S PSUDIV=PSUSNDR,PSUDIVI="H"
    56         ;
    57         ;
    58         K ^TMP($J,"PSUMIT") ;   array for multiple items
    59         D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I")
    60         I '$D(^TMP($J,"PSUMIT")) Q  ;
    61         D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
    62         ;
    63         S PSUITDA=0 F  S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0  D ITEM
    64         Q
    65 ITEM    ;EP  process one item within the invoice
    66         N PSUIT ;  array for one item
    67         M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
    68         ;
    69         I (PSUIT(7)<PSUSDT) Q
    70         I (PSUIT(7)>PSUEDT) Q
    71         ;     pull adjustments   3.2.6.2.8
    72         N PSUMADJ
    73         D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I")
    74         I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ")
    75         ;
    76         ;
    77         ;      Review/Process Adjustments
    78         I $D(PSUMADJ) S PSUADJDA=0 F  S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0  D
    79         . N PSUADJ
    80         . M PSUADJ=PSUMADJ(PSUADJDA)
    81         . ;
    82         . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5)  ; 3.2.6.2.8    Drug or Supply
    83         . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5)  ; 3.2.6.2.11   OrderUnits
    84         . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5)  ; 3.2.6.2.12   Price
    85         . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity
    86         . Q
    87         ;
    88         I 'PSUIT(2) Q  ; per Lina 10/7/98  if qty = 0 don't send record
    89         ;    work on the order unit PSUIT(3)
    90         I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina
    91         I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11
    92         ;
    93         ;    further process item fields  3.2.6.2.9 +
    94         ;
    95         ;    look for/ construct Dispense Units per Order Unit
    96         ;    Store in PSUIT(9999)  3.2.6.2.13
    97         ;  Get Related Drug Fields 3.2.6.2.9
    98         ;
    99         N PSUDRUG
    100         S PSUDRDA=0
    101         ;  if PSUIT(1) is a supply item the following will not be computed
    102         I PSUIT(1)=+PSUIT(1) D
    103         . S PSUDRDA=PSUIT(1)
    104         . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
    105         . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I")
    106         . D MOVEI^PSUTL("PSUDRUG")
    107         . S PSUIT(1)=PSUDRUG(.01)                          ; Generic Name
    108         . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name"
    109         . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC"
    110         ;   further process fields
    111         ;   fill in drug fields for supply items
    112         I 'PSUDRDA D
    113         . S PSUDRUG(.01)="Unknown Generic Name"
    114         . S PSUDRUG(21)="Unknown VA Product Name"
    115         . S PSUDRUG(31)="No NDC"
    116         ;
    117         ; NDC
    118         I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC"
    119         ;
    120         ;      dispense units per order unit 3.2.6.2.13
    121         ;
    122         S PSUIT(9999)=0
    123         I $L(PSUIT(13)),$G(PSUDRDA) D
    124         . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,""))
    125         . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403")
    126         ;
    127         I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina
    128         ;
    129         ;PSU*4*13 Comment out To prevent XINDEX from complaining about
    130         ; ^PSUPR7 (CoreFLS remnance)
    131         ;Create "RECORDS" global for CoreFLS data
    132         ;I $D(PSUFLSFG) S PSUA="" D
    133         ;.F  S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA=""  D SIMPL^PSUPR7
    134         ;
    135         ;   Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
    136         S PSUR=$$RECORD()
    137         ;   Store Records by Division
    138         S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
    139         S PSULC=PSULC+1
    140         S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR
    141         Q
    142         ;
    143 RECORD()        ;EP Assemble record
    144         N PSUR
    145         S PSUR(2)=$G(PSUDIV)
    146         S PSUR(3)=$G(PSUDIVI)
    147         S PSUR(4)=PSUIT(7)\1      ; 3.2.6.2.2
    148         S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9
    149         S PSUR(6)=$G(PSUDRUG(2))  ;  ""
    150         S PSUR(7)=PSUIT(1)     ; 3.2.6.2.8
    151         S PSUR(9)=PSUIT(13)    ; 3.2.6.2.9
    152         S PSUR(10)=PSUIT(14)    ;    ""
    153         S PSUR(11)=PSUIT(15)    ;    ""
    154         S PSUR(12)=$G(PSUDRUG(14.5)) ; ""
    155         S PSUR(13)=PSUIT(3)     ; 3.2.6.2.11
    156         S PSUR(16)=PSUIT(9999)  ; 3.2.6.2.13
    157         S PSUR(17)=PSUIT(2)     ; 3.2.6.2.10
    158         S PSUR(18)=PSUIT(4)     ; 3.2.6.2.12
    159         S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14
    160         S PSUR(20)=PSUORD(1)    ; 3.2.6.2.5
    161         S PSUR(21)=PSUINV(.01)  ; 3.2.6.2.6
    162         S PSUR(22)=""
    163         S PSUR=""
    164         S I=0 F  S I=$O(PSUR(I)) Q:I'>0  S PSUR(I)=$TR(PSUR(I),"^","'")
    165         S I=0 F  S I=$O(PSUR(I)) Q:I'>0  S $P(PSUR,U,I)=PSUR(I)
    166         S PSUR=PSUR_U
    167         Q PSUR
    168         ;
    169 DIV     ;Find division or outpatient site
    170         ;
    171         S PSUDIV=""
    172         N MAPLOCI
    173         D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I")
    174         D MOVEMI^PSUTL("MAPLOCI")
    175         ;
    176         I $G(MAPLOCI(PSUINV(4),.01)) D
    177         .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
    178         .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
    179         I '$G(MAPLOCI(PSUINV(4),.01)) D
    180         .S PSUDIV=PSUSNDR
    181         .S PSUDIVI="H"
    182         Q
    183         ;
    184         ;
    185 MAP     ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy
    186         ;Location is mapped to a division or outpatient site.  If it is not
    187         ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a
    188         ;global to be mailed to the user.
    189         ;
    190         K NAOU,DAPH
    191         K MAPLOCI,MAPLOC
    192         S PSUNAM=0            ;This is the name of the NAOU or DA PHARMACY
    193         ;
    194         F  S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM=""  D
    195         .S IEN=0
    196         .F  S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN=""  D
    197         ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)")
    198         ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN)
    199         ..D MAP1
    200         ;
    201         Q
    202         ;
    203 MAP1    ;MAP continued. This subroutine takes the IEN from file 58.8 and looks
    204         ;to see if it is in file 59.7, field 90.02 or 90.03.
    205         ;
    206         ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is
    207         ;no value in subfield .02 or .03, then an NAOU has not been mapped.
    208         ;
    209         ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is
    210         ;no value in subfield .02 or .03, then a DA PHARMACY location has not
    211         ;been mapped.
    212         ;
    213         ;Keep only the entries that are NOT mapped
    214         ;
    215         N PSUDA
    216         ;
    217         ;Look for unmapped NAOU's
    218         ;I $G(NAOU(IEN),1) D
    219         I $G(^PS(59.7,1,90.02,IEN,0)) D
    220         .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI")
    221         .S PSUDA=0
    222         .F  S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA=""  D
    223         ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA)
    224         ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA)
    225         M ^XTMP(PSUARSUB,"NAOU")=NAOU          ;only unmapped NAOU locations.
    226         ;
    227         ;
    228         ;Look for unmapped DA PHARM
    229         I $G(^PS(59.7,1,90.03,IEN,0)) D
    230         .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC")
    231         .S PSUDA=0
    232         .F  S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA=""  D
    233         ..;PSU*4*13 Correct Problm DA Pharm Report
    234         ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA)
    235         ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA)
    236         M ^XTMP(PSUARSUB,"DAPH")=DAPH      ;only unmapped DA PHARM locations.
    237         Q
    238         ;
    239 WRD()   ;EP    Process for ward;
    240         N PSUWD,PSUWDDA,PSUDIV
    241         S PSUDIV=""
    242         D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I")
    243         D MOVEMI^PSUTL("PSUWD")
    244         ; loop ward pointers
    245         S PSUWDDA=0
    246         F  S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0  D  Q:$L(PSUDIV)
    247         . S X=$$VALI^PSUTL(42,PSUWDDA,.015)
    248         . Q:'X
    249         . S X=$$VALI^PSUTL(40.8,X,1)
    250         . I $L(X) S PSUDIV=X
    251         ; return value of PSUDIV "" or = facility number
    252         Q PSUDIV
    253         ;
    254 INP()   ;EP  Process for Inpatient
    255         ; within package call to AR/WS that pulls/builds Inpatient AOU Site
    256         ; uses IEN Value to AOU STATs file 58.5
    257         N PSUARSUB,PSUARJOB
    258         S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2)
    259         N PSULOC
    260         S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
    261         S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found
    262         S:X="NULL" X=""
    263         Q X
    264         ;
    265 IV()    ;EP  Process,PSUIVDA for IV
    266         ; PSULOC IEN  pharmacy location in file 58.8 (DRUG ACCOUNTABILITY)
    267         N PSUIV,PSUDIV
    268         S PSUDIV=""
    269         D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I")
    270         D MOVEMI^PSUTL("PSUIV")
    271         S PSUIVDA=0
    272         F  S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0  D  Q:$L(PSUDIV)
    273         . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02)
    274         . I X S X=$$VALI^PSUTL(40.8,X,1)
    275         . I $L(X) S PSUDIV=X
    276         ;
    277         Q PSUDIV
    278         ;
    279 OUT()   ;EP  Process for Outpatient
    280         S X=$$VALI^PSUTL(58.8,PSULOC,20)
    281         I X S X=$$VALI^PSUTL(59,X,.06)
    282         Q X
    283         ;
     1PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ;20 AUG 1999
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;DBIAs
     4 ; Reference to file #58.811 supported by DBIA 2521
     5 ; Reference to file #51.5   supported by DBIA 1931
     6 ; Reference to file #50     supported by DBIA 221
     7 ; Reference to file #58.8   supported by DBIA 2519
     8 ; Reference to file #42     supported by DBIA 2440
     9 ; Reference to file #40.8   supported by DBIA 2438
     10 ; Reference to file #59.5   supported by DBIA 2499
     11 ; Reference to file #59     supported by DBIA 2510
     12 ;
     13EN ;
     14 S PSUEND=PSUEDT
     15 S PSUEDT=PSUEDT\1+.24
     16 S:'$D(PSUPRJOB) PSUPRJOB=$J
     17 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J
     18 I '$D(^XTMP(PSUPRSUB)) D
     19 . S ^XTMP(PSUPRSUB,"RECORDS",0)=""
     20 . S X1=DT,X2=6 D C^%DTC
     21 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
     22 ;
     23 S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
     24 D MAP
     25 ;
     26 ;   check for Drug Accountability
     27 S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY")
     28 I 'X Q  ; not installed
     29 ;
     30 S X1=PSUSDT,X2=-45 ;backup by 45 days per revision
     31 D C^%DTC
     32 S PSUDT=X
     33 ;    loop thru invoice date field xref
     34 F  S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT  Q:PSUDT'>0  D
     35 .  S PSUORDA=0 F  S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0  D
     36 .. S PSUINVDA=0 F  S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0  D INVOICE
     37 Q
     38 ;
     39INVOICE ;EP process an invoice within an order
     40 N PSUSTAT
     41 S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2)
     42 I PSUSTAT'="C" Q  ;     3.2.6.1
     43 N PSUORD
     44 D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD")
     45 ;
     46 S PSUINV=""
     47 N PSURDT,PSUIVNUM
     48 D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I")
     49 D MOVEI^PSUTL("PSUINV")
     50 S PSURDT=PSUINV(8)
     51 S PSUIVNUM=PSUINV(.01)
     52 ;
     53 I $G(PSUINV(4)) D DIV
     54 I $L(PSUDIV) S PSUDIVI=""
     55 E  S PSUDIV=PSUSNDR,PSUDIVI="H"
     56 ;
     57 ;
     58 K ^TMP($J,"PSUMIT") ;   array for multiple items
     59 D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I")
     60 I '$D(^TMP($J,"PSUMIT")) Q  ;
     61 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
     62 ;
     63 S PSUITDA=0 F  S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0  D ITEM
     64 Q
     65ITEM ;EP  process one item within the invoice
     66 N PSUIT ;  array for one item
     67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
     68 ;
     69 I (PSUIT(7)<PSUSDT) Q
     70 I (PSUIT(7)>PSUEDT) Q
     71 ;     pull adjustments   3.2.6.2.8
     72 N PSUMADJ
     73 D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I")
     74 I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ")
     75 ;
     76 ;
     77 ;      Review/Process Adjustments
     78 I $D(PSUMADJ) S PSUADJDA=0 F  S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0  D
     79 . N PSUADJ
     80 . M PSUADJ=PSUMADJ(PSUADJDA)
     81 . ;
     82 . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5)  ; 3.2.6.2.8    Drug or Supply
     83 . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5)  ; 3.2.6.2.11   OrderUnits
     84 . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5)  ; 3.2.6.2.12   Price
     85 . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity
     86 . Q
     87 ;
     88 I 'PSUIT(2) Q  ; per Lina 10/7/98  if qty = 0 don't send record
     89 ;    work on the order unit PSUIT(3)
     90 I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina
     91 I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11
     92 ;
     93 ;    further process item fields  3.2.6.2.9 +
     94 ;
     95 ;    look for/ construct Dispense Units per Order Unit
     96 ;    Store in PSUIT(9999)  3.2.6.2.13
     97 ;  Get Related Drug Fields 3.2.6.2.9
     98 ;
     99 N PSUDRUG
     100 S PSUDRDA=0
     101 ;  if PSUIT(1) is a supply item the following will not be computed
     102 I PSUIT(1)=+PSUIT(1) D
     103 . S PSUDRDA=PSUIT(1)
     104 . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB
     105 . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I")
     106 . D MOVEI^PSUTL("PSUDRUG")
     107 . S PSUIT(1)=PSUDRUG(.01)                          ; Generic Name
     108 . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name"
     109 . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC"
     110 ;   further process fields
     111 ;   fill in drug fields for supply items
     112 I 'PSUDRDA D
     113 . S PSUDRUG(.01)="Unknown Generic Name"
     114 . S PSUDRUG(21)="Unknown VA Product Name"
     115 . S PSUDRUG(31)="No NDC"
     116 ;
     117 ; NDC
     118 I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC"
     119 ;
     120 ;      dispense units per order unit 3.2.6.2.13
     121 ;
     122 S PSUIT(9999)=0
     123 I $L(PSUIT(13)),$G(PSUDRDA) D
     124 . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,""))
     125 . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403")
     126 ;
     127 I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina
     128 ;
     129 ;Create "RECORDS" global for CoreFLS data
     130 I $D(PSUFLSFG) S PSUA="" D
     131 .F  S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA=""  D SIMPL^PSUPR7
     132 ;
     133 ;   Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
     134 S PSUR=$$RECORD()
     135 ;   Store Records by Division
     136 S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1)
     137 S PSULC=PSULC+1
     138 S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR
     139 Q
     140 ;
     141RECORD() ;EP Assemble record
     142 N PSUR
     143 S PSUR(2)=$G(PSUDIV)
     144 S PSUR(3)=$G(PSUDIVI)
     145 S PSUR(4)=PSUIT(7)\1      ; 3.2.6.2.2
     146 S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9
     147 S PSUR(6)=$G(PSUDRUG(2))  ;  ""
     148 S PSUR(7)=PSUIT(1)     ; 3.2.6.2.8
     149 S PSUR(9)=PSUIT(13)    ; 3.2.6.2.9
     150 S PSUR(10)=PSUIT(14)    ;    ""
     151 S PSUR(11)=PSUIT(15)    ;    ""
     152 S PSUR(12)=$G(PSUDRUG(14.5)) ; ""
     153 S PSUR(13)=PSUIT(3)     ; 3.2.6.2.11
     154 S PSUR(16)=PSUIT(9999)  ; 3.2.6.2.13
     155 S PSUR(17)=PSUIT(2)     ; 3.2.6.2.10
     156 S PSUR(18)=PSUIT(4)     ; 3.2.6.2.12
     157 S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14
     158 S PSUR(20)=PSUORD(1)    ; 3.2.6.2.5
     159 S PSUR(21)=PSUINV(.01)  ; 3.2.6.2.6
     160 S PSUR(22)=""
     161 S PSUR=""
     162 S I=0 F  S I=$O(PSUR(I)) Q:I'>0  S PSUR(I)=$TR(PSUR(I),"^","'")
     163 S I=0 F  S I=$O(PSUR(I)) Q:I'>0  S $P(PSUR,U,I)=PSUR(I)
     164 S PSUR=PSUR_U
     165 Q PSUR
     166 ;
     167DIV ;Find division or outpatient site
     168 ;
     169 S PSUDIV=""
     170 N MAPLOCI
     171 D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I")
     172 D MOVEMI^PSUTL("MAPLOCI")
     173 ;
     174 I $G(MAPLOCI(PSUINV(4),.01)) D
     175 .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1)
     176 .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06)
     177 I '$G(MAPLOCI(PSUINV(4),.01)) D
     178 .S PSUDIV=PSUSNDR
     179 .S PSUDIVI="H"
     180 Q
     181 ;
     182 ;
     183MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy
     184 ;Location is mapped to a division or outpatient site.  If it is not
     185 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a
     186 ;global to be mailed to the user.
     187 ;
     188 K NAOU,DAPH
     189 K MAPLOCI,MAPLOC
     190 S PSUNAM=0            ;This is the name of the NAOU or DA PHARMACY
     191 ;
     192 F  S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM=""  D
     193 .S IEN=0
     194 .F  S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN=""  D
     195 ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)")
     196 ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN)
     197 ..D MAP1
     198 ;
     199 Q
     200 ;
     201MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks
     202 ;to see if it is in file 59.7, field 90.02 or 90.03.
     203 ;
     204 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is
     205 ;no value in subfield .02 or .03, then an NAOU has not been mapped.
     206 ;
     207 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is
     208 ;no value in subfield .02 or .03, then a DA PHARMACY location has not
     209 ;been mapped.
     210 ;
     211 ;Keep only the entries that are NOT mapped
     212 ;
     213 N PSUDA
     214 ;
     215 ;Look for unmapped NAOU's
     216 ;I $G(NAOU(IEN),1) D
     217 I $G(^PS(59.7,1,90.02,IEN,0)) D
     218 .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI")
     219 .S PSUDA=0
     220 .F  S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA=""  D
     221 ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA)
     222 ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA)
     223 M ^XTMP(PSUARSUB,"NAOU")=NAOU          ;only unmapped NAOU locations.
     224 ;
     225 ;
     226 ;Look for unmapped DA PHARM
     227 I $G(^PS(59.7,1,90.03,IEN,0)) D
     228 .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC")
     229 .S PSUDA=0
     230 .F  S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA=""  D
     231 ..I $G(MAPLOC(PSUDA,.02))'="" K NAOU(PSUDA)
     232 ..I $G(MAPLOC(PSUDA,.03))'="" K NAOU(PSUDA)
     233 M ^XTMP(PSUARSUB,"DAPH")=DAPH      ;only unmapped DA PHARM locations.
     234 Q
     235 ;
     236WRD() ;EP    Process for ward;
     237 N PSUWD,PSUWDDA,PSUDIV
     238 S PSUDIV=""
     239 D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I")
     240 D MOVEMI^PSUTL("PSUWD")
     241 ; loop ward pointers
     242 S PSUWDDA=0
     243 F  S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0  D  Q:$L(PSUDIV)
     244 . S X=$$VALI^PSUTL(42,PSUWDDA,.015)
     245 . Q:'X
     246 . S X=$$VALI^PSUTL(40.8,X,1)
     247 . I $L(X) S PSUDIV=X
     248 ; return value of PSUDIV "" or = facility number
     249 Q PSUDIV
     250 ;
     251INP() ;EP  Process for Inpatient
     252 ; within package call to AR/WS that pulls/builds Inpatient AOU Site
     253 ; uses IEN Value to AOU STATs file 58.5
     254 N PSUARSUB,PSUARJOB
     255 S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2)
     256 N PSULOC
     257 S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
     258 S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found
     259 S:X="NULL" X=""
     260 Q X
     261 ;
     262IV() ;EP  Process,PSUIVDA for IV
     263 ; PSULOC IEN  pharmacy location in file 58.8 (DRUG ACCOUNTABILITY)
     264 N PSUIV,PSUDIV
     265 S PSUDIV=""
     266 D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I")
     267 D MOVEMI^PSUTL("PSUIV")
     268 S PSUIVDA=0
     269 F  S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0  D  Q:$L(PSUDIV)
     270 . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02)
     271 . I X S X=$$VALI^PSUTL(40.8,X,1)
     272 . I $L(X) S PSUDIV=X
     273 ;
     274 Q PSUDIV
     275 ;
     276OUT() ;EP  Process for Outpatient
     277 S X=$$VALI^PSUTL(58.8,PSULOC,20)
     278 I X S X=$$VALI^PSUTL(59,X,.06)
     279 Q X
     280 ;
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSURT1.m

    r613 r623  
    1 PSURT1  ;BIR/RDC - PATIENT DEMOGRAPHIC RETRANSMITION; APR 2, 2007 ; 4/2/07 11:01am
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
    3         ;
    4         ; THIS PROGRAM WILL ALLOW THE RETRANSMITION OF THE PATIENT
    5         ; DEMOGRAPHIC DATA FOR THE PBM EXTRACT USING THE DATA
    6         ; FROM ^PSUDEM (59.9) FOR RUN TIME OPTIMIZATION
    7         ;
    8 EN      ; ENTRY POINT
    9         NEW P,SDT,EDT,WHEN,NOGOOD,TMON,RMONTH,PMON,SMON,EMON,RTYPE,SRANGE,ERANGE
    10         S P=""
    11         ; move call to CLEANUP^PSUHL to routine PSUCP (PSU*4*12)
    12         S SDT=$O(^PSUDEM("B",P))
    13         I 'SDT W !,"NO DATA AVAILABLE - NOTIFY YOUR SUPERVISOR" Q
    14         S EDT=$O(^PSUDEM("B",P),-1)
    15         S Y=SDT X ^DD("DD") S START=Y
    16         S Y=EDT-1 X ^DD("DD") S STOP=Y
    17         W !,"This option will allow the retransmission of Patient Demographic and Outpatient Visit data stored in the PBM PATIENT DEMOGRAPHICS FILE. Statistical data starting from "
    18         W START
    19         W " through "
    20         W STOP
    21         W " is available for retransmission."
    22         W !
    23         ;
    24         ; let fileman get response
    25         S DIR("A")="Is this a monthly report",DIR(0)="YO"
    26         D ^DIR K DIR
    27         ;
    28         S NOGOOD=1
    29         I Y=1 S NOGOOD=0 D MONTH
    30         I Y=0 S NOGOOD=0 D RANGE
    31         Q:NOGOOD
    32         D PROCESS        ; *** process the extract ***
    33         Q
    34         ;
    35 MONTH   ;      *** allow only whole months to be processed ***
    36         W !
    37         S TMON=$E(DT,4,5)
    38         S DIR("A")="Select Month/Year",DIR(0)="F" D ^DIR
    39         K DIR,DIR("A")
    40         I $D(DIRUT) S NOGOOD=1 Q
    41         S %DT="MP" D ^%DT K %DT
    42         I Y=-1 W !!,"Invalid Month/Year.  Please Reenter a month and year." G MONTH
    43         S RMONTH=$$FMTE^XLFDT(Y) W " ("_RMONTH_")"
    44         ; S %DT(0)=SDT,%DT="MP"
    45         ; S X=Y
    46         ; D ^%DT K %DT
    47         I $E(Y,4,5)=TMON S Y=-1
    48         I Y=-1 W !!,"Data for the entire month of "_RMONTH_" is not available.  Please reenter a month/year." G MONTH
    49         I Y>DT W !!,"You may not select a date from the future.  Please reenter a month/year within the valid parameters." G MONTH
    50         ;
    51         S PSURMON=Y
    52         S SMON=$E(PSURMON,1,5)_"00"
    53         S EMON=$E(PSURMON,1,5)_"99"
    54         S RTYPE="M"
    55         Q
    56         ;
    57 RANGE   ;             *** process a range of dates from within file #59.9 ***
    58         S %DT(0)=SDT
    59         ;
    60 BGNRNG  ;
    61         W !
    62         S %DT="PAE",%DT("A")="Select start date: " D ^%DT K %DT,%DT("A")
    63         I X="^"!($G(DTOUT)) S NOGOOD=1 Q
    64         I Y=-1 W !!,"Invalid date.  Please reenter a start date." G BGNRNG
    65         I Y=DT W !!,"Today is not a valid start date.  Please reenter a start date." G BGNRNG
    66         ;
    67         I Y>DT W !!,"You may not select a date in the future.  Please reenter a start date." G BGNRNG
    68         ;
    69         S SRANGE=Y          ;  *  start with this date  ***
    70         ;
    71 ENDRNG  ;
    72         W !
    73         S %DT="PAE",%DT("A")="Select stop date: " D ^%DT K %DT,%DT("A")
    74         I X="^"!($G(DTOUT)) S NOGOOD=1 Q
    75         I Y=-1 W !!,"Invalid date.  Please reenter a stop date." G ENDRNG
    76         I Y=DT W !!,"Statistical data has not been compiled for current date.  Please reenter a stop date." G ENDRNG
    77         ;
    78         I Y<SRANGE W !!,"You need to select a stop date greater than your start date.  Please reenter your start/stop dates." G BGNRNG
    79         ;
    80         I Y>DT W !!,"You may not select a date in the future.  Please reenter a stop date." G ENDRNG
    81         ;
    82         S ERANGE=Y                ; *  end at this date  ***
    83         ;
    84         S RTYPE="R"
    85         K %DT(0)
    86         ;
    87         Q
    88 PROCESS ;
    89         I RTYPE="R" S (START,PSUSRNG)=SRANGE,(LAST,PSUERNG)=ERANGE
    90         I RTYPE="M" S START=SMON,LAST=EMON
    91         ;
    92         S PSUSMRY=0
    93         W !!
    94         S DIR("A")="Do you want a copy of this report sent to you in a MailMan message?"
    95         S DIR(0)="YO"
    96         S DIR("B")="NO"
    97         D ^DIR K DIR,DIR(0)
    98         I Y="^" Q
    99         I Y=1 S PSUMME=1,PSUDUZ=DUZ
    100         ;
    101         I RTYPE="M" D
    102         . W !!
    103         . S DIR("A")="Send this to the PBM section for addition to the master file?"
    104         . S DIR(0)="YO"
    105         . S DIR("B")="NO"
    106         . D ^DIR K DIR,DIR(0)
    107         . I Y=1 S PSUMSTR=1
    108         ;
    109         I Y="^" Q
    110         S PSUSTART=START,PSULAST=LAST
    111         K %DT,PSUWHEN
    112         D NOW^%DTC S %DT="REAX",%DT(0)="A",%DT("B")="NOW",%DT("A")="Queue to run at what time: " D ^%DT
    113         S PSUWHEN=Y
    114         S ZTRTN="EN^PSURT2",ZTIO="",ZTDESC="RETRASMISSION OF PT DEMOGRAPHICS",ZTDTH=PSUWHEN
    115         S ZTSAVE("PSUSTART")=""
    116         S ZTSAVE("PSULAST")=""
    117         S ZTSAVE("PSUMME")=""
    118         S ZTSAVE("PSUMSTR")=""
    119         S ZTSAVE("PSURMON")=""
    120         S ZTSAVE("PSUSRNG")=""
    121         S ZTSAVE("PSUERNG")=""
    122         S ZTSAVE("PSUDUZ")=""
    123         S ZTSAVE("PSUSMRY")=""
    124         ;
    125         ; D ^PSURT2
    126         ; Q
    127         ;
    128         D ^%ZTLOAD
    129         Q
    130         ;
     1PSURT1 ;BIR/RDC - PATIENT DEMOGRAPHIC RETRANSMITION; 31 MAR 2004
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;
     4 ; THIS PROGRAM WILL ALLOW THE RETRANSMITION OF THE PATIENT
     5 ; DEMOGRAPHIC DATA FOR THE PBM EXTRACT USING THE DATA
     6 ; FROM ^PSUDEM (59.9) FOR RUN TIME OPTIMIZATION
     7 ;
     8EN ; ENTRY POINT
     9 NEW P,SDT,EDT,WHEN,NOGOOD,TMON,RMONTH,PMON,SMON,EMON,RTYPE,SRANGE,ERANGE
     10 S P=""
     11 D CLEANUP^PSUHL
     12 S SDT=$O(^PSUDEM("B",P))
     13 I 'SDT W !,"NO DATA AVAILABLE - NOTIFY YOUR SUPERVISOR" Q
     14 S EDT=$O(^PSUDEM("B",P),-1)
     15 S Y=SDT X ^DD("DD") S START=Y
     16 S Y=EDT-1 X ^DD("DD") S STOP=Y
     17 W !,"This option will allow the retransmission of Patient Demographic and Outpatient Visit data stored in the PBM PATIENT DEMOGRAPHICS FILE. Statistical data starting from "
     18 W START
     19 W " through "
     20 W STOP
     21 W " is available for retransmission."
     22 W !
     23 ;
     24 ; let fileman get response
     25 S DIR("A")="Is this a monthly report",DIR(0)="YO"
     26 D ^DIR K DIR
     27 ;
     28 S NOGOOD=1
     29 I Y=1 S NOGOOD=0 D MONTH
     30 I Y=0 S NOGOOD=0 D RANGE
     31 Q:NOGOOD
     32 D PROCESS        ; *** process the extract ***
     33 Q
     34 ;
     35MONTH ;      *** allow only whole months to be processed ***
     36 W !
     37 S TMON=$E(DT,4,5)
     38 S DIR("A")="Select Month/Year",DIR(0)="F" D ^DIR
     39 K DIR,DIR("A")
     40 I $D(DIRUT) S NOGOOD=1 Q
     41 S %DT="MP" D ^%DT K %DT
     42 I Y=-1 W !!,"Invalid Month/Year.  Please Reenter a month and year." G MONTH
     43 S RMONTH=$$FMTE^XLFDT(Y) W " ("_RMONTH_")"
     44 ; S %DT(0)=SDT,%DT="MP"
     45 ; S X=Y
     46 ; D ^%DT K %DT
     47 I $E(Y,4,5)=TMON S Y=-1
     48 I Y=-1 W !!,"Data for the entire month of "_RMONTH_" is not available.  Please reenter a month/year." G MONTH
     49 I Y>DT W !!,"You may not select a date from the future.  Please reenter a month/year within the valid parameters." G MONTH
     50 ;
     51 S PSURMON=Y
     52 S SMON=$E(PSURMON,1,5)_"00"
     53 S EMON=$E(PSURMON,1,5)_"99"
     54 S RTYPE="M"
     55 Q
     56 ;
     57RANGE ;             *** process a range of dates from within file #59.9 ***
     58 S %DT(0)=SDT
     59 ;
     60BGNRNG ;
     61 W !
     62 S %DT="PAE",%DT("A")="Select start date: " D ^%DT K %DT,%DT("A")
     63 I X="^"!($G(DTOUT)) S NOGOOD=1 Q
     64 I Y=-1 W !!,"Invalid date.  Please reenter a start date." G BGNRNG
     65 I Y=DT W !!,"Today is not a valid start date.  Please reenter a start date." G BGNRNG
     66 ;
     67 I Y>DT W !!,"You may not select a date in the future.  Please reenter a start date." G BGNRNG
     68 ;
     69 S SRANGE=Y          ;  *  start with this date  ***
     70 ;
     71ENDRNG ;
     72 W !
     73 S %DT="PAE",%DT("A")="Select stop date: " D ^%DT K %DT,%DT("A")
     74 I X="^"!($G(DTOUT)) S NOGOOD=1 Q
     75 I Y=-1 W !!,"Invalid date.  Please reenter a stop date." G ENDRNG
     76 I Y=DT W !!,"Statistical data has not been compiled for current date.  Please reenter a stop date." G ENDRNG
     77 ;
     78 I Y<SRANGE W !!,"You need to select a stop date greater than your start date.  Please reenter your start/stop dates." G BGNRNG
     79 ;
     80 I Y>DT W !!,"You may not select a date in the future.  Please reenter a stop date." G ENDRNG
     81 ;
     82 S ERANGE=Y                ; *  end at this date  ***
     83 ;
     84 S RTYPE="R"
     85 K %DT(0)
     86 ;
     87 Q
     88PROCESS ;
     89 I RTYPE="R" S (START,PSUSRNG)=SRANGE,(LAST,PSUERNG)=ERANGE
     90 I RTYPE="M" S START=SMON,LAST=EMON
     91 ;
     92 S PSUSMRY=0
     93 W !!
     94 S DIR("A")="Do you want a copy of this report sent to you in a MailMan message?"
     95 S DIR(0)="YO"
     96 S DIR("B")="NO"
     97 D ^DIR K DIR,DIR(0)
     98 I Y="^" Q
     99 I Y=1 S PSUMME=1,PSUDUZ=DUZ
     100 ;
     101 I RTYPE="M" D
     102 . W !!
     103 . S DIR("A")="Send this to the PBM section for addition to the master file?"
     104 . S DIR(0)="YO"
     105 . S DIR("B")="NO"
     106 . D ^DIR K DIR,DIR(0)
     107 . I Y=1 S PSUMSTR=1
     108 ;
     109 I Y="^" Q
     110 S PSUSTART=START,PSULAST=LAST
     111 K %DT,PSUWHEN
     112 D NOW^%DTC S %DT="REAX",%DT(0)="A",%DT("B")="NOW",%DT("A")="Queue to run at what time: " D ^%DT
     113 S PSUWHEN=Y
     114 S ZTRTN="EN^PSURT2",ZTIO="",ZTDESC="RETRASMISSION OF PT DEMOGRAPHICS",ZTDTH=PSUWHEN
     115 S ZTSAVE("PSUSTART")=""
     116 S ZTSAVE("PSULAST")=""
     117 S ZTSAVE("PSUMME")=""
     118 S ZTSAVE("PSUMSTR")=""
     119 S ZTSAVE("PSURMON")=""
     120 S ZTSAVE("PSUSRNG")=""
     121 S ZTSAVE("PSUERNG")=""
     122 S ZTSAVE("PSUDUZ")=""
     123 S ZTSAVE("PSUSMRY")=""
     124 ;
     125 ; D ^PSURT2
     126 ; Q
     127 ;
     128 D ^%ZTLOAD
     129 Q
     130 ;
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM1.m

    r613 r623  
    1 PSUSUM1 ;BIR/DAM - Summary Report for Provider Extract ; 2/23/07 2:18pm
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
    3         ;
    4         ; No DBIA's required.
    5         ;
    6 EN      ;EN CALLED FROM ^PSUDEM4
    7         ;
    8         D PULL^PSUCP
    9         D DATE
    10         D PRSUM^PSUDEM5     ;Mail message
    11         Q
    12         ;
    13 DATE    ;Convert dates to external format
    14         ;
    15         S %H=$E($H,1,5)      ;today's date
    16         D YX^%DTC
    17         N PSUD S PSUD=Y
    18         ;
    19         S Y=PSUSDT           ;Start date of extract
    20         D DD^%DT
    21         N PSUS S PSUS=Y
    22         ;
    23         S Y=PSUEDT           ;End date of extract
    24         D DD^%DT
    25         N PSUE S PSUE=Y
    26         ;
    27         D SUMM
    28         Q
    29         ;
    30 SUMM    ;Compose summary mail message by placing all text into a
    31         ;temporary global, designated ^XTMP("PSU_"_PSUJOB,"PSUSUM",
    32         ;
    33         ;
    34         ;Report header
    35         I '$D(^XTMP("PSU_"_PSUJOB,"PSUPROV")) D  Q
    36         .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="No data to report"
    37         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="Provider Summary Report                                         "_PSUD
    38         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",2)=""                          ;Blank line
    39         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",3)="                 "_PSUS_"  through  "_PSUE
    40         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",4)=""
    41         S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",5),"-",80)=""              ;Separator Bar
    42         S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",7),"-",80)=""
    43         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",8)=""
    44         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",9)="IEN        Provider Name (SSN)                        Missing Data"
    45         S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",10),"-",80)=""
    46         D PROV
    47         ;
    48         Q
    49         ;
    50 PROV    ;Gather missing provider data for summary report
    51         ;
    52         N PSUSSN3,PSUMIS,PSUCL,PSUSS,PSUSP,PSUSUB,PSULN,PSUM
    53         S PSUM=0
    54         S PSULN=11
    55         S PSUIP=0
    56         F  S PSUIP=$O(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)) Q:PSUIP=""  Q:PSUIP["U"  D
    57         .I $P($G(^VA(200,PSUIP,"PS")),"^",6)=4 Q  ; Exclude if the provider type is "FEE BASIS" (PSU*4*12)
    58         .S PSUSSN3=$E($P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,3),6,9)
    59         .I PSUSSN3="" S PSUSSN3="????",PSUMIS="SSN" D NAM             ;No SSN
    60         .S PSUCL=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,5)
    61         .I PSUCL="" S PSUMIS="PROVIDER CLASS" D NAM   ;No Class
    62         .S PSUSS=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,6)
    63         .I PSUSS="" S PSUMIS="SERVICE/SECTION" D NAM  ;No Ser/Sec
    64         .S PSUSP=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,7)
    65         .I PSUSP="" S PSUMIS="SPECIALTY" D NAM        ;No Spec
    66         .Q:PSUSP["Intern"    ;Omit interns from missing subspec. on report
    67         .Q:PSUSP["Resident"   ;Omit residents from missing subspc. on report
    68         .S PSUSUB=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,8)
    69         .I PSUSUB="" S PSUMIS="SUBSPECIALTY" D NAM    ;No Subsp
    70         Q
    71         ;
    72 NAM     ;Get Provider name and create entry line in summary report
    73         ;
    74         N PSUNAM,PSUT1,PSUT2,PSUT3,PSUT4,S1,S2,S3
    75         N PSUT5,PSUT6,PSUT7,PSUT8,PSUT9,PSUT10
    76         ;
    77         S PSUT4=" "
    78         S PSUT1=11
    79         S PSUT2=PSUT1-$L(PSUIP)
    80         F S1=1:1:(PSUT2-1) S PSUT3(S1)=" " D
    81         .S PSUT4=PSUT4_PSUT3(S1)       ;First tab position
    82         ;
    83         S PSUNAM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,9)
    84         ;
    85         S PSUT5=" "
    86         S PSUT6=54
    87         S PSUT7=(PSUT6-$L(PSUNAM)-7-$L(PSUT4)-$L(PSUIP))
    88         F S2=1:1:(PSUT7-1) S PSUT8(S2)=" " D
    89         .S PSUT5=PSUT5_PSUT8(S2)        ;Second tab position
    90         ;
    91         S PSUT10=" "
    92         F S3=1:1:(PSUT6-1) S PSUT9(S3)=" " D
    93         .S PSUT10=PSUT10_PSUT9(S3)      ;Third tab position
    94         ;
    95         ;
    96         ;I '$D(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)) D
    97         S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUIP_PSUT4_PSUNAM_" ("_PSUSSN3_")"_PSUT5_PSUMIS
    98         F I=1:1:5 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN-I)),U,1)[PSUNAM D
    99         .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUT10_PSUMIS
    100         ;
    101         I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)),U,1)[PSUNAM D
    102         .S PSUM=PSUM+1       ;Set a counter for number of patients accessed
    103         .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",6)="Total Number of Incomplete Provider Records Extracted: "_PSUM
    104         S PSULN=PSULN+1
    105         ;
    106         Q
     1PSUSUM1 ;BIR/DAM - Summary Report for Provider Extract ; 20 DEC 2001
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;
     4 ; No DBIA's required.
     5 ;
     6EN ;EN CALLED FROM ^PSUDEM4
     7 ;
     8 D PULL^PSUCP
     9 D DATE
     10 D PRSUM^PSUDEM5     ;Mail message
     11 Q
     12 ;
     13DATE ;Convert dates to external format
     14 ;
     15 S %H=$E($H,1,5)      ;today's date
     16 D YX^%DTC
     17 N PSUD S PSUD=Y
     18 ;
     19 S Y=PSUSDT           ;Start date of extract
     20 D DD^%DT
     21 N PSUS S PSUS=Y
     22 ;
     23 S Y=PSUEDT           ;End date of extract
     24 D DD^%DT
     25 N PSUE S PSUE=Y
     26 ;
     27 D SUMM
     28 Q
     29 ;
     30SUMM ;Compose summary mail message by placing all text into a
     31 ;temporary global, designated ^XTMP("PSU_"_PSUJOB,"PSUSUM",
     32 ;
     33 ;
     34 ;Report header
     35 I '$D(^XTMP("PSU_"_PSUJOB,"PSUPROV")) D  Q
     36 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="No data to report"
     37 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",1)="Provider Summary Report                                         "_PSUD
     38 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",2)=""                          ;Blank line
     39 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",3)="                 "_PSUS_"  through  "_PSUE
     40 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",4)=""
     41 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",5),"-",80)=""              ;Separator Bar
     42 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",7),"-",80)=""
     43 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",8)=""
     44 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",9)="IEN        Provider Name (SSN)                        Missing Data"
     45 S $P(^XTMP("PSU_"_PSUJOB,"PSUSUM",10),"-",80)=""
     46 D PROV
     47 ;
     48 Q
     49 ;
     50PROV ;Gather missing provider data for summary report
     51 ;
     52 N PSUSSN3,PSUMIS,PSUCL,PSUSS,PSUSP,PSUSUB,PSULN,PSUM
     53 S PSUM=0
     54 S PSULN=11
     55 S PSUIP=0
     56 F  S PSUIP=$O(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)) Q:PSUIP=""  Q:PSUIP["U"  D
     57 .S PSUSSN3=$E($P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,3),6,9)
     58 .I PSUSSN3="" S PSUSSN3="????",PSUMIS="SSN" D NAM             ;No SSN
     59 .S PSUCL=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,5)
     60 .I PSUCL="" S PSUMIS="PROVIDER CLASS" D NAM   ;No Class
     61 .S PSUSS=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,6)
     62 .I PSUSS="" S PSUMIS="SERVICE/SECTION" D NAM  ;No Ser/Sec
     63 .S PSUSP=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,7)
     64 .I PSUSP="" S PSUMIS="SPECIALTY" D NAM        ;No Spec
     65 .Q:PSUSP["Intern"    ;Omit interns from missing subspec. on report
     66 .Q:PSUSP["Resident"   ;Omit residents from missing subspc. on report
     67 .S PSUSUB=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,8)
     68 .I PSUSUB="" S PSUMIS="SUBSPECIALTY" D NAM    ;No Subsp
     69 Q
     70 ;
     71NAM ;Get Provider name and create entry line in summary report
     72 ;
     73 N PSUNAM,PSUT1,PSUT2,PSUT3,PSUT4,S1,S2,S3
     74 N PSUT5,PSUT6,PSUT7,PSUT8,PSUT9,PSUT10
     75 ;
     76 S PSUT4=" "
     77 S PSUT1=11
     78 S PSUT2=PSUT1-$L(PSUIP)
     79 F S1=1:1:(PSUT2-1) S PSUT3(S1)=" " D
     80 .S PSUT4=PSUT4_PSUT3(S1)       ;First tab position
     81 ;
     82 S PSUNAM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,9)
     83 ;
     84 S PSUT5=" "
     85 S PSUT6=54
     86 S PSUT7=(PSUT6-$L(PSUNAM)-7-$L(PSUT4)-$L(PSUIP))
     87 F S2=1:1:(PSUT7-1) S PSUT8(S2)=" " D
     88 .S PSUT5=PSUT5_PSUT8(S2)        ;Second tab position
     89 ;
     90 S PSUT10=" "
     91 F S3=1:1:(PSUT6-1) S PSUT9(S3)=" " D
     92 .S PSUT10=PSUT10_PSUT9(S3)      ;Third tab position
     93 ;
     94 ;
     95 ;I '$D(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)) D
     96 S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUIP_PSUT4_PSUNAM_" ("_PSUSSN3_")"_PSUT5_PSUMIS
     97 F I=1:1:5 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN-I)),U,1)[PSUNAM D
     98 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)=PSUT10_PSUMIS
     99 ;
     100 I $P($G(^XTMP("PSU_"_PSUJOB,"PSUSUM",PSULN)),U,1)[PSUNAM D
     101 .S PSUM=PSUM+1       ;Set a counter for number of patients accessed
     102 .S ^XTMP("PSU_"_PSUJOB,"PSUSUM",6)="Total Number of Incomplete Provider Records Extracted: "_PSUM
     103 S PSULN=PSULN+1
     104 ;
     105 Q
  • WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUVIT1.m

    r613 r623  
    1 PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003 ; 10/9/07 7:03am
    2         ;;4.0;PHARMACY BENEFITS MANAGEMENT;**11**;MARCH, 2005;Build 8
    3         ;
    4         ;DBIA's
    5         ;References to file #4       - the INSTITUTION file
    6         ;  DBIA 10090 for: the STATION field  - #99
    7         ;
    8         ;References to file #120.5    - the GMRV VITAL MEASUREMENT file
    9         ;  DBIA 1381 for:   the DATE/TIME VITALS TAKEN field - #.01
    10         ;                   the VITAL TYPE field #.03
    11         ;                   the RATE field #1.2
    12         ;                   the QUALIFIER field #5
    13         ;
    14         ;References to file #120.51- the GMRV VITAL TYPE file
    15         ;       DBIA 1382 for: the NAME field - #.01
    16         ;
    17         ;References to file #120.52 - the GMRV VITAL QUALIFIER file
    18         ;       DBIA 4504 for: the QUALIFIER field #.01
    19         ;
    20         ;References to file #9000010.11 - the V IMMUNIZATION file
    21         ;       DBIA 4567 for: the EVENT DATE AND TIME field #1202
    22         ;                      the IMMUNIZATION field #.01
    23         ;
    24         ;References to file #2   - the PATIENT file
    25         ;       DBIA 10035 for:  the SOCIAL SECURITY NUMBER field #.09
    26         ;       DBIA 3504 for: the TEST PATIENT INDICATOR field #.6
    27         ;
    28         ;References to file #9999999.14 - the IMMUNIZATION file
    29         ;       DBIA 2454 for: the NAME field #.01
    30         ;
    31 EN      ;ENtry POINT - Routine control module
    32         ;
    33         N SDATE,EDATE,PSUFAC,PSUIDATE,PSUQCNT,PSUQNUM
    34         N MAXLINE,LINECNT,MSGCNT,I,J,K,Z,LINETOT
    35         S PSUVTMP(0)="TEMP ARRAY FOR PSUVIT1 PROCESSING"
    36         D SETUP
    37         D VITALS
    38         D VITALS2
    39         D IMMUNS
    40         D MAILIT
    41         Q          ;  **  end of routine control module **
    42         ;
    43 SETUP   ; SET UP PARTITION FOR VITALS/IMMUNIZATION EXTRACT
    44         ;
    45         S LINEMAX=$$VAL^PSUTL(4.3,1,8.3)       ; ** get maximum line length **
    46         S:LINEMAX=""!(LINEMAX>10000) LINEMAX=10000
    47         ;
    48         ; SET EXTRACT DATE
    49         S %H=$H
    50         D YMD^%DTC
    51         S $P(^TMP("PSUVI",$J),U,3)=X
    52         ;
    53         ; GET TIME WINDOW
    54         S SDATE=PSUSDT\1-.0001
    55         S EDATE=PSUEDT\1+.2359
    56         ;
    57         ; GET FACILITY
    58         S PSUFAC=PSUSNDR
    59         ;
    60         ; SET VARIABLES
    61         I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUFLAG"))=1 D  ;AUTOJOBED
    62         . S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13"
    63         . S PSUAUTO=1
    64         S LINECNT=999999
    65         S LINETOT=0
    66         ;
    67         Q                         ;  ** end of SETUP  **
    68         ;
    69 VITALS  ; EXTRACT VITAL DATA
    70         ;
    71         N PSUDATE,PSUV,PSUQ,PSUVREC,PSUPTREC,PSUPTPTR,PSUVPTR,PSUQPTR
    72         N PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT
    73         N Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG
    74         N PSULN,PSUTXT
    75         ;
    76         S PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY"""
    77         ;
    78         ;                          ** Loop through date index for valid dates **
    79         S PSUDATE=SDATE
    80         ;PSU*4*11 Added null ptr notification.
    81         S PSUTXT(1)="The following IEN(s) have a null pointer in the PATIENT (#2) field of"
    82         S PSUTXT(2)="the GMRV VITAL MEASUREMENT file (#120.5).  Please notify your IRM and"
    83         S PSUTXT(3)="submit a remedy ticket for help in evaluating the record."
    84         S PSULN=3
    85         F  S PSUDATE=$O(^GMR(120.5,"B",PSUDATE)) Q:PSUDATE>EDATE!('PSUDATE)  D
    86         . S PSUV=""                      ; ** loop thru vitals for each date **
    87         . F  S PSUV=$O(^GMR(120.5,"B",PSUDATE,PSUV)) Q:PSUV=""  D
    88         .. Q:$P($D(^GMR(120.5,PSUV,2)),U)  ;** quit if vital entered in error **
    89         .. S PSUVREC=$G(^GMR(120.5,PSUV,0)) Q:'PSUVREC
    90         .. S PSUPTPTR=$P(PSUVREC,U,2)    ; ** point to PATIENT **
    91         .. I PSUPTPTR="" D  Q            ; ** quit if no patient pointer **
    92         ... S PSULN=PSULN+1
    93         ... S PSUTXT(PSULN)=PSUV
    94         .. Q:$G(^DPT(PSUPTPTR,0))=""     ; ** quit if no patient record **
    95         .. S PSUPTREC=^DPT(PSUPTPTR,0)   ; ** get patient record **
    96         .. S PSUSSN=$P(PSUPTREC,U,9)     ; ** get SSN
    97         .. Q:$E(PSUSSN,1,5)="00000"      ; ** quit if invalid patient **
    98         .. Q:$P(PSUPTREC,U,21)=1
    99         .. Q:$P(PSUVREC,U,3)=""          ; ** quit if no pointer **
    100         .. S PSUVPTR=$P(PSUVREC,U,3)     ; ** point to VITAL  **
    101         .. S PSUVTYPE=$P(^GMRD(120.51,PSUVPTR,0),U)  ; ** get VITAL TYPE **
    102         .. Q:PSUVLIST'[PSUVTYPE         ; ** screen out invalid vital types **
    103         .. S PSURTYPE="V"                ; ** set record type **
    104         .. S PSUICN=$$GETICN^MPIF001(PSUPTPTR)  ; ** get ICN **
    105         .. I $P(PSUICN,U)="-1" S PSUICN=""
    106         .. S PSUVRATE=$P(PSUVREC,U,8)
    107         .. S PSUVUNIT=""                 ; ** set vital unit rate **
    108         .. S:PSUVTYPE="PULSE OXIMETRY" PSUVUNIT="%"
    109         .. S:PSUVTYPE="WEIGHT" PSUVUNIT="LBS"
    110         .. S:PSUVTYPE="HEIGHT" PSUVUNIT="IN"
    111         .. S (PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4)=""
    112         .. D:$D(^GMR(120.5,PSUV,5,0))    ; ** get qualifiers **
    113         ... S (PSUQNUM,PSUQCNT)=0
    114         ... F  S PSUQNUM=$O(^GMR(120.5,PSUV,5,PSUQNUM)) Q:'+PSUQNUM  D
    115         .... S PSUQPTR=^GMR(120.5,PSUV,5,PSUQNUM,0)
    116         .... S PSUQCNT=PSUQCNT+1
    117         .... S QQ="PSUVQ"_PSUQCNT
    118         .... S @QQ=$P(^GMRD(120.52,PSUQPTR,0),U)
    119         .. S Z="$"
    120         .. S PSUVMSG=Z_PSUFAC_Z_PSUDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_""_Z_PSUVTYPE_Z_PSUVRATE_Z_PSUVUNIT_Z_PSUVQ1_Z_PSUVQ2_Z_PSUVQ3_Z_PSUVQ4_Z
    121         .. S PSUVMSG=$TR(PSUVMSG,"^","'")
    122         .. S PSUVMSG=$TR(PSUVMSG,Z,U)
    123         .. ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG
    124         .. S ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG
    125         ;PSU*4*11 Send null ptr notifications to PBM group.
    126         I PSULN>3 D
    127         . S XMTEXT="PSUTXT(",XMY("G.PSU PBM")=""
    128         . S XMSUB="** PBM vitals extract detected null patient pointer(s) **"
    129         . S XMDUZ="Pharmacy Benefits Management Package"
    130         . N DIFROM D ^XMD
    131         Q
    132         ;               ** end of vital extract **
    133 VITALS2 ; LOAD SORTED ARRAY INTO ^XTMP
    134         ;
    135         N VPT,VPTV
    136         S VPT=""
    137         ; ** F  S VPT=$O(PSUVTMP(VPT)) Q:VPT=""  D
    138         F  S VPT=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT)) Q:VPT=""  D
    139         . S VPTV=""
    140         . ; **F  S VPTV=$O(PSUVTMP(VPT,VPTV)) Q:VPTV=""  D
    141         . F  S VPTV=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)) Q:VPTV=""  D
    142         .. ; ** S X=PSUVTMP(VPT,VPT                     ; * LOAD VITAL RECORD
    143         .. S X=^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)
    144         .. S LINECNT=LINECNT+1
    145         .. S LINETOT=LINETOT+1
    146         .. I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
    147         .. I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q  ; load
    148         .. F J=254:-1 Q:$E(X,J)="^"
    149         .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,J)
    150         .. S LINECNT=LINECNT+1
    151         .. S LINETOT=LINETOT+1
    152         .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,J,J+253)
    153         Q
    154         ;
    155 IMMUNS  ;
    156         N PSUDATE,ICNT,PSUINUM,PSUIREC,PSUPTPTR,PSUPTREC,PSUSSN,PSUIMPTR
    157         N PSUIMM,PSUICN,PSURTYPE,PSUIMSG
    158         ;
    159         S (PSUMCNT,PSUINUM)=0
    160         F  S PSUINUM=$O(^AUPNVIMM(PSUINUM)) Q:'PSUINUM  D
    161         . S PSUIDATE=$P($G(^AUPNVIMM(PSUINUM,12)),"U")  ; ** get IMM date **
    162         . Q:$P(PSUIDATE,U)=""               ; ** quit if date is null **
    163         . Q:PSUIDATE<SDATE!(PSUIDATE>EDATE)  ; ** quit if date out of range **
    164         . S PSUIREC=^AUPNVIMM(PSUINUM,0)    ; ** get IMM record **
    165         . S PSUPTPTR=$P(PSUIREC,U,2)        ; ** pointer to PAT file **
    166         . S PSUPTREC=^DPT(PSUPTPTR,0)       ; ** get patient record **
    167         . S PSUSSN=$P(PSUPTREC,U,9)
    168         . Q:$E(PSUSSN,1,5)="00000"          ; ** quit if invalid patient **
    169         . I $P(PSUPTREC,U,21)=1 Q
    170         . S PSUIMPTR=$P(PSUIREC,U)         ; ** point to IMM file **
    171         . S PSUIMM=$P(^AUTTIMM(PSUIMPTR,0),U)  ; ** get IMM name **
    172         . S PSUICN=$$GETICN^MPIF001(PSUPTPTR)  ; ** set ICN **
    173         . I $P(PSUICN,U)="-1" S PSUICN=""
    174         . S PSURTYPE="I"                    ; ** set record type **
    175         . S Z="$"
    176         . S PSUIMSG=Z_PSUFAC_Z_PSUIDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_PSUIMM_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z
    177         . S PSUIMSG=$TR(PSUIMSG,"^","'")
    178         . S X=$TR(PSUIMSG,Z,U)
    179         . ;   *** load ^XTMP  ***
    180         . S LINECNT=LINECNT+1
    181         . S LINETOT=LINETOT+1
    182         . I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
    183         . I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q  ; load
    184         . F K=254:-1 Q:$E(X,K)="^"
    185         . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,K)
    186         . S LINECNT=LINECNT+1
    187         . S LINETOT=LINETOT+1
    188         . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,K,K+253)
    189         ;                                           *** save message count  ***
    190         S:$G(MSGCNT) ^XTMP("PSU_"_PSUJOB,"PSUVI","MSGTCNT")=MSGCNT
    191         S ^XTMP("PSU_"_PSUJOB,"PSUVI","LINECNT")=LINETOT
    192         Q                                                ; ** quit IMMUNS **
    193         ;
    194 MAILIT  ; MAIL VITAL & IMMUNIZATION EXTRACT MESSAGES
    195         ;
    196         D ^PSUVIT2
    197         Q                         ;  **  quit for MAILIT  **
    198         ;
     1PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003
     2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
     3 ;
     4 ;DBIA's
     5 ;References to file #4       - the INSTITUTION file
     6 ;  DBIA 10090 for: the STATION field  - #99
     7 ;
     8 ;References to file #120.5    - the GMRV VITAL MEASUREMENT file
     9 ;  DBIA 1381 for:   the DATE/TIME VITALS TAKEN field - #.01
     10 ;                   the VITAL TYPE field #.03
     11 ;                   the RATE field #1.2
     12 ;                   the QUALIFIER field #5
     13 ;
     14 ;References to file #120.51- the GMRV VITAL TYPE file
     15 ;       DBIA 1382 for: the NAME field - #.01
     16 ;
     17 ;References to file #120.52 - the GMRV VITAL QUALIFIER file
     18 ;       DBIA 4504 for: the QUALIFIER field #.01
     19 ;
     20 ;References to file #9000010.11 - the V IMMUNIZATION file
     21 ;       DBIA 4567 for: the EVENT DATE AND TIME field #1202
     22 ;                      the IMMUNIZATION field #.01
     23 ;
     24 ;References to file #2   - the PATIENT file
     25 ;       DBIA 10035 for:  the SOCIAL SECURITY NUMBER field #.09
     26 ;       DBIA 3504 for: the TEST PATIENT INDICATOR field #.6
     27 ;
     28 ;References to file #9999999.14 - the IMMUNIZATION file
     29 ;       DBIA 2454 for: the NAME field #.01
     30 ;
     31EN ;ENtry POINT - Routine control module
     32 ;
     33 N SDATE,EDATE,PSUFAC,PSUIDATE,PSUQCNT,PSUQNUM
     34 N MAXLINE,LINECNT,MSGCNT,I,J,K,Z,LINETOT
     35 S PSUVTMP(0)="TEMP ARRAY FOR PSUVIT1 PROCESSING"
     36 D SETUP
     37 D VITALS
     38 D VITALS2
     39 D IMMUNS
     40 D MAILIT
     41 Q          ;  **  end of routine control module **
     42 ;
     43SETUP ; SET UP PARTITION FOR VITALS/IMMUNIZATION EXTRACT
     44 ;
     45 S LINEMAX=$$VAL^PSUTL(4.3,1,8.3)       ; ** get maximum line length **
     46 S:LINEMAX=""!(LINEMAX>10000) LINEMAX=10000
     47 ;
     48 ; SET EXTRACT DATE
     49 S %H=$H
     50 D YMD^%DTC
     51 S $P(^TMP("PSUVI",$J),U,3)=X
     52 ;
     53 ; GET TIME WINDOW
     54 S SDATE=PSUSDT\1-.0001
     55 S EDATE=PSUEDT\1+.2359
     56 ;
     57 ; GET FACILITY
     58 S PSUFAC=PSUSNDR
     59 ;
     60 ; SET VARIABLES
     61 I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUFLAG"))=1 D  ;AUTOJOBED
     62 . S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13"
     63 . S PSUAUTO=1
     64 S LINECNT=999999
     65 S LINETOT=0
     66 ;
     67 Q                         ;  ** end of SETUP  **
     68 ;
     69VITALS ; EXTRACT VITAL DATA
     70 ;
     71 N PSUDATE,PSUV,PSUQ,PSUVREC,PSUPTREC,PSUPTPTR,PSUVPTR,PSUQPTR
     72 N PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT
     73 N Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG
     74 ;
     75 S PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY"""
     76 ;
     77 ;                          ** Loop through date index for valid dates **
     78 S PSUDATE=SDATE
     79 F  S PSUDATE=$O(^GMR(120.5,"B",PSUDATE)) Q:PSUDATE>EDATE!('PSUDATE)  D
     80 . S PSUV=""                      ; ** loop thru vitals for each date **
     81 . F  S PSUV=$O(^GMR(120.5,"B",PSUDATE,PSUV)) Q:PSUV=""  D
     82 .. Q:$P($D(^GMR(120.5,PSUV,2)),U)  ;** quit if vital entered in error **
     83 .. S PSUVREC=$G(^GMR(120.5,PSUV,0)) Q:'PSUVREC
     84 .. S PSUPTPTR=$P(PSUVREC,U,2)    ; ** point to PATIENT **
     85 .. Q:$G(^DPT(PSUPTPTR,0))=""     ; ** quit if no patient record **
     86 .. S PSUPTREC=^DPT(PSUPTPTR,0)   ; ** get patient record **
     87 .. S PSUSSN=$P(PSUPTREC,U,9)     ; ** get SSN
     88 .. Q:$E(PSUSSN,1,5)="00000"      ; ** quit if invalid patient **
     89 .. Q:$P(PSUPTREC,U,21)=1
     90 .. Q:$P(PSUVREC,U,3)=""          ; ** quit if no pointer **
     91 .. S PSUVPTR=$P(PSUVREC,U,3)     ; ** point to VITAL  **
     92 .. S PSUVTYPE=$P(^GMRD(120.51,PSUVPTR,0),U)  ; ** get VITAL TYPE **
     93 .. Q:PSUVLIST'[PSUVTYPE         ; ** screen out invalid vital types **
     94 .. S PSURTYPE="V"                ; ** set record type **
     95 .. S PSUICN=$$GETICN^MPIF001(PSUPTPTR)  ; ** get ICN **
     96 .. I $P(PSUICN,U)="-1" S PSUICN=""
     97 .. S PSUVRATE=$P(PSUVREC,U,8)
     98 .. S PSUVUNIT=""                 ; ** set vital unit rate **
     99 .. S:PSUVTYPE="PULSE OXIMETRY" PSUVUNIT="%"
     100 .. S:PSUVTYPE="WEIGHT" PSUVUNIT="LBS"
     101 .. S:PSUVTYPE="HEIGHT" PSUVUNIT="IN"
     102 .. S (PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4)=""
     103 .. D:$D(^GMR(120.5,PSUV,5,0))    ; ** get qualifiers **
     104 ... S (PSUQNUM,PSUQCNT)=0
     105 ... F  S PSUQNUM=$O(^GMR(120.5,PSUV,5,PSUQNUM)) Q:'+PSUQNUM  D
     106 .... S PSUQPTR=^GMR(120.5,PSUV,5,PSUQNUM,0)
     107 .... S PSUQCNT=PSUQCNT+1
     108 .... S QQ="PSUVQ"_PSUQCNT
     109 .... S @QQ=$P(^GMRD(120.52,PSUQPTR,0),U)
     110 .. S Z="$"
     111 .. S PSUVMSG=Z_PSUFAC_Z_PSUDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_""_Z_PSUVTYPE_Z_PSUVRATE_Z_PSUVUNIT_Z_PSUVQ1_Z_PSUVQ2_Z_PSUVQ3_Z_PSUVQ4_Z
     112 .. S PSUVMSG=$TR(PSUVMSG,"^","'")
     113 .. S PSUVMSG=$TR(PSUVMSG,Z,U)
     114 .. ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG
     115 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG
     116 Q
     117 ;               ** end of vital extract **
     118VITALS2 ; LOAD SORTED ARRAY INTO ^XTMP
     119 ;
     120 N VPT,VPTV
     121 S VPT=""
     122 ; ** F  S VPT=$O(PSUVTMP(VPT)) Q:VPT=""  D
     123 F  S VPT=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT)) Q:VPT=""  D
     124 . S VPTV=""
     125 . ; **F  S VPTV=$O(PSUVTMP(VPT,VPTV)) Q:VPTV=""  D
     126 . F  S VPTV=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)) Q:VPTV=""  D
     127 .. ; ** S X=PSUVTMP(VPT,VPT                     ; * LOAD VITAL RECORD
     128 .. S X=^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)
     129 .. S LINECNT=LINECNT+1
     130 .. S LINETOT=LINETOT+1
     131 .. I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
     132 .. I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q  ; load
     133 .. F J=254:-1 Q:$E(X,J)="^"
     134 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,J)
     135 .. S LINECNT=LINECNT+1
     136 .. S LINETOT=LINETOT+1
     137 .. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,J,J+253)
     138 Q
     139 ;
     140IMMUNS ;
     141 N PSUDATE,ICNT,PSUINUM,PSUIREC,PSUPTPTR,PSUPTREC,PSUSSN,PSUIMPTR
     142 N PSUIMM,PSUICN,PSURTYPE,PSUIMSG
     143 ;
     144 S (PSUMCNT,PSUINUM)=0
     145 F  S PSUINUM=$O(^AUPNVIMM(PSUINUM)) Q:'PSUINUM  D
     146 . S PSUIDATE=$P($G(^AUPNVIMM(PSUINUM,12)),"U")  ; ** get IMM date **
     147 . Q:$P(PSUIDATE,U)=""               ; ** quit if date is null **
     148 . Q:PSUIDATE<SDATE!(PSUIDATE>EDATE)  ; ** quit if date out of range **
     149 . S PSUIREC=^AUPNVIMM(PSUINUM,0)    ; ** get IMM record **
     150 . S PSUPTPTR=$P(PSUIREC,U,2)        ; ** pointer to PAT file **
     151 . S PSUPTREC=^DPT(PSUPTPTR,0)       ; ** get patient record **
     152 . S PSUSSN=$P(PSUPTREC,U,9)
     153 . Q:$E(PSUSSN,1,5)="00000"          ; ** quit if invalid patient **
     154 . I $P(PSUPTREC,U,21)=1 Q
     155 . S PSUIMPTR=$P(PSUIREC,U)         ; ** point to IMM file **
     156 . S PSUIMM=$P(^AUTTIMM(PSUIMPTR,0),U)  ; ** get IMM name **
     157 . S PSUICN=$$GETICN^MPIF001(PSUPTPTR)  ; ** set ICN **
     158 . I $P(PSUICN,U)="-1" S PSUICN=""
     159 . S PSURTYPE="I"                    ; ** set record type **
     160 . S Z="$"
     161 . S PSUIMSG=Z_PSUFAC_Z_PSUIDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_PSUIMM_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z
     162 . S PSUIMSG=$TR(PSUIMSG,"^","'")
     163 . S X=$TR(PSUIMSG,Z,U)
     164 . ;   *** load ^XTMP  ***
     165 . S LINECNT=LINECNT+1
     166 . S LINETOT=LINETOT+1
     167 . I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
     168 . I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q  ; load
     169 . F K=254:-1 Q:$E(X,K)="^"
     170 . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,K)
     171 . S LINECNT=LINECNT+1
     172 . S LINETOT=LINETOT+1
     173 . S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,K,K+253)
     174 ;                                           *** save message count  ***
     175 S:$G(MSGCNT) ^XTMP("PSU_"_PSUJOB,"PSUVI","MSGTCNT")=MSGCNT
     176 S ^XTMP("PSU_"_PSUJOB,"PSUVI","LINECNT")=LINETOT
     177 Q                                                ; ** quit IMMUNS **
     178 ;
     179MAILIT ; MAIL VITAL & IMMUNIZATION EXTRACT MESSAGES
     180 ;
     181 D ^PSUVIT2
     182 Q                         ;  **  quit for MAILIT  **
     183 ;
Note: See TracChangeset for help on using the changeset viewer.