APSPCO ; IHS/MSC/PLS - List Manager Complete Orders ;24-Jul-2013 08:46;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1013,1014,1015,1016**;Sep 23, 2004;Build 74
; Modified - IHS/MSC/PB - 09/28/012 - OERR+26 to remove patient language flag
;=================================================================
;IHS/MSC/MGH Patch 1016 ADDITEM +2,6,11 Added visual for a flagged order
EN ; -- main entry point for APSP COMPLETE ORDERS
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX^PSOORFIN
N APSPINS,APSPQ,LOCFLG,APSPLOCS,APSPSORT,APSPORPT
N APSPPTAY,LOCLIEN,APSPFRST
S APSPQ=0,APSPINS=""
S APSPINS=$$DIR^APSPUTIL("Y","Would you like orders for all Ordering Institutions","Yes",,.APSPQ)
I APSPINS D
.S APSPINS="*"
E D Q:APSPQ
.S APSPINS=$$GETIEN^APSPUTIL(4,"Select Ordering Institution: ",.APSPQ)
Q:APSPQ
S APSPFRST=1
D EN^VALM("APSP COMPLETE ORDERS")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
Q
;
HDR ; -- header code
;S XQORM("#")=$O(^ORD(101,"B","APSPCO PROCESS SELECT",0))_"^1:"_VALMCNT
S VALMHDR(1)="Outpatient Pharmacy Pending Orders"_" Related Institution: "_$S(APSPINS:$$GET1^DIQ(4,APSPINS,.01),APSPINS="*":"ALL",1:" ")
S VALMHDR(2)="Sorted by: "_$G(APSPSORT)_" Restrict to locations: "_$S(LOCFLG:"ON for "_$$GET1^DIQ(9009033.6,$G(LOCLIEN),.01),1:"OFF")
Q
;
INIT ; -- init variables and list array
S LOCFLG=$G(LOCFLG,0)
S APSPORPT=$G(APSPORPT,+$$GET^XPAR("ALL","APSPCO DEFAULT VIEW"))
S APSPSORT=$S(APSPORPT:"Patient Name",1:"Order Date")
D CLEAN^VALM10
D BUILDLST(APSPINS)
M SAVE=VALM
S:APSPFRST APSPFRST=0
Q
; Set line into array
SETARR(LINE,TEXT,IEN) ;EP-
S @VALMAR@(LINE,0)=TEXT
S:$G(IEN) @VALMAR@("IDX",LINE,LINE)=""
S @VALMAR@(LINE,"POFIEN")=LINE_U_IEN
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K SAVE
Q
;
EXPND ; -- expand code
Q
; Build list of pending orders
BUILDLST(INST) ;EP-
I APSPORPT D TOGORPT Q
N LD,RI,IEN
S VALMCNT=0 ;LOCFLG=0
;D CHGCAP^VALM("ORDDT","Order Date")
D UPDCOL(APSPORPT)
S LD=0 F S LD=$O(^PS(52.41,"AD",LD)) Q:'LD D
.S RI=0 F S RI=$O(^PS(52.41,"AD",LD,RI)) Q:'RI D
..Q:(INST'="*")&(RI'=INST)
..S IEN=0 F S IEN=$O(^PS(52.41,"AD",LD,RI,IEN)) Q:'IEN D
...D ADDITEM(IEN,INST)
Q
; Add a single line item
ADDITEM(IEN,INST) ;EP-
N NOD0,LINE,COM,PTLOCK,FLAG
S FLAG=0
S NOD0=$G(^PS(52.41,IEN,0))
Q:'NOD0
I LOCFLG Q:'$D(APSPLOCS($P(NOD0,U,13)))
I $P($G(^PS(52.41,IEN,0)),"^",23)=1 S FLAG=1
S VALMCNT=VALMCNT+1
S COM=$P($G(^PS(52.41,IEN,4)),U)
S LINE=$$SETFLD^VALM1(VALMCNT,"","ITEM")
S LINE=$$SETFLD^VALM1($$HRN^AUPNPAT($P(NOD0,U,2),$S(INST:INST,1:DUZ(2))),LINE,"HRN")
S LINE=$$SETFLD^VALM1($S($$PTLOCK($P(NOD0,U,2)):"*",1:"")_$$GET1^DIQ(2,$P(NOD0,U,2),.01),LINE,"PATIENT")
S LINE=$$SETFLD^VALM1($$FMTE^XLFDT($$DOB^AUPNPAT($P(NOD0,U,2)),"5Z"),LINE,"DOB")
S LINE=$$SETFLD^VALM1($S($L(COM):"#",1:""),LINE,"CFLG")
S LINE=$$SETFLD^VALM1($TR($$FMTE^XLFDT($E($P(NOD0,U,6),1,12),"5Z"),"@"," "),LINE,"ORDDT")
S LINE=$$SETFLD^VALM1($$GET1^DIQ(44,$P(NOD0,U,13),.01),LINE,"HOSPLOC")
;S LINE=$$SETFLD^VALM1($P(NOD0,U),LINE,"ORDNUM")
S LINE=$$SETFLD^VALM1($S($L(COM)>30:$E(COM,1,27)_"...",1:COM),LINE,"COMMENT")
I FLAG=1 D CNTRL^VALM10(VALMCNT,1,3,IORVON,IORVOFF,0)
D SETARR(VALMCNT,LINE,IEN)
Q
; Return lock state of patient record
PTLOCK(DFN) ;EP-
Q ''$G(^XTMP("PSSLOCK",DFN))
;
LOCARY ;EP-
N LOCARY,LP
S LOCLIEN=$$PMTLLST^APSPCO1()
Q:'LOCLIEN
K APSPLOCS
S LP=0
F S LP=$O(^APSPLRS(9009033.6,LOCLIEN,1,LP)) Q:'LP D
.S APSPLOCS(+^APSPLRS(9009033.6,LOCLIEN,1,LP,0))=""
Q
; Build list of orders using location list
LOCLST ;EP-
N LD,RI,IEN
S VALMCNT=0
D CLEAN^VALM10
;D CHGCAP^VALM("ORDDT","Order Date")
D UPDCOL(APSPORPT)
S LD=0 F S LD=$O(^PS(52.41,"AD",LD)) Q:'LD D
.S RI=0 F S RI=$O(^PS(52.41,"AD",LD,RI)) Q:'RI D
..Q:(APSPINS'="*")&(RI'=APSPINS)
..S IEN=0 F S IEN=$O(^PS(52.41,"AD",LD,RI,IEN)) Q:'IEN D
...D ADDITEM(IEN,APSPINS)
S VALMBCK="R"
D FIRST^VALM4
D RE^VALM4
Q
; Custom sort list
SORTLST ;EP-
N NARY,APSPQ,LP,CNT,NOD0,IDX,CL,IEN,POFIEN,SELITMS
D FULL^VALM1
S APSPQ=0
S CNT=0
S SELITMS="1:HRN;2:Patient Name;3:DOB;4:Order Date;5:Hospital Location"
S CL=+$$DIR^APSPUTIL("S^"_SELITMS,1,,.APSPQ)
Q:APSPQ
S APSPSORT=$P($P(SELITMS,";",CL),":",2)
S LP=0
F S LP=$O(@VALMAR@(LP)) Q:'LP D
.S POFIEN=$P(@VALMAR@(LP,"POFIEN"),U,2)
.Q:'POFIEN
.S NOD0=$G(^PS(52.41,POFIEN,0))
.Q:'NOD0
.S IDX=$S(CL=1:+$$HRN^AUPNPAT($P(NOD0,U,2),$S(APSPINS:APSPINS,1:DUZ(2))),CL=2:$$GET1^DIQ(2,$P(NOD0,U,2),.01),CL=3:$$DOB^AUPNPAT($P(NOD0,U,2)),CL=5:$$GET1^DIQ(44,$P(NOD0,U,13),.01),1:$$SRTDT()) ;1:$P(NOD0,U,6))
.S CNT=CNT+1
.S NARY("IDX",IDX,POFIEN)=""
D CLEAN^VALM10
S VALMCNT=0
S LP=""
F S LP=$O(NARY("IDX",LP)) Q:'$L(LP) D
.S IEN=0
.F S IEN=$O(NARY("IDX",LP,IEN)) Q:'IEN D
..D ADDITEM(IEN,APSPINS)
S VALMBCK="R"
D FIRST^VALM4
D RE^VALM4
Q
; Return sort date
SRTDT() ;EP-
Q $S($P(NOD0,U,6):$P(NOD0,U,6),$P(NOD0,U,12):$P(NOD0,U,12),1:$$NOW^XLFDT())
; Post message that patient record is locked
LOCCHK ;EP-
N MSG,DFN,ITM,VAL
S MSG="",VALMBCK=""
D EN^VALM2(XQORNOD(0),"SO")
S ITM=$O(VALMY(""))
Q:'ITM
S VAL=$P(@VALMAR@(ITM,"POFIEN"),U,2)
Q:'VAL
I 'APSPORPT D Q:'DFN
.S DFN=$P($G(^PS(52.41,VAL,0)),U,2)
E S DFN=VAL
I $G(^XTMP("PSSLOCK",DFN)) D
.S MSG=$$WHO^PSSLOCK(DFN)
.S MSG=$$GET1^DIQ(200,+$P($G(^XTMP("PSSLOCK",DFN)),U),.01)_" is editing orders ("_$$FMTE^XLFDT($E($P($G(^XTMP("PSSLOCK",DFN)),U,2),1,12),"5Z")_")"
S VALMSG=$S($L(MSG):MSG,1:"This patient is available for processing.")
Q
;
SELORD ;
N Y
S Y=$P(XQORNOD(0),"=",2)
D PROC1
Q
; Process patient orders
PROCESS ;EP-
N DIR,DUOUT,DIRUT,Y
S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_VALMCNT D ^DIR
I $D(DIRUT)!$D(DUOUT) S VALMBCK="R" Q
PROC1 ;EP-
N SAVEPAT,LASTDFN,APSPORD,LST,APSPLP,PSODFN,PAT,PSOLK
N MEDA,PSOFIN,X,MEDP,PATA,ORD
K APSPPTAY
S SAVEPAT=""
I +Y D FULL^VALM1 S LST=Y
D BLDPTARY(.APSPPTAY,LST,APSPORPT)
S LASTDFN=0
S APSPLP=0 F S APSPLP=$O(APSPPTAY(APSPLP)) Q:'APSPLP D
.N VALM,VALMPGE
.I SAVEPAT'=APSPLP,$O(PSORX("PSOL",0))!($D(RXRS)) D
..N ZP
..S ZP=PSODFN
..S PSODFN=+PSODFN D LBL^PSOORFIN ;MGH ADD
..S PSODFN=ZP
.S (PAT,SAVEPAT)=APSPLP
.I '$D(^PS(52.41,"P",PAT)) D
..W !,"The orders for this patient have already been processed!"
.D LK^PSOORFIN I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1 Q
.I $$CHK^PSODPT(PAT_U_$P($G(^DPT(PAT,0)),U),1,1)<0 S PSOLK=1 S X=PAT D ULP^PSOORFIN K PSOQFLG,PSOQQ Q
.S (PSODFN,Y)=PAT_U_$P($G(^DPT(PAT,0)),U)
.S (PATA,LASTDFN)=+PSODFN
.D SETPTCX^APSPFUNC(+PSODFN)
.D:'$G(MEDA) PROFILE^PSOORFI2 M VALM=SAVE
.S Y=PSODFN
.I $G(MEDP) D Q
..D SPL^PSOORFIN D OERR(Y) S PSOFIN=1 D QU^PSOORFIN S X=PSOPTLOK D KLLP^PSOORFIN,ULP^PSOORFIN,KLL^PSOORFIN
.D SDFN^PSOORFIN
.D POST(Y)
.I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S X=SAVEPAT D ULP^PSOORFIN K PSOQFLG Q
.S APSPORD=0 F S APSPORD=$O(^PS(52.41,"P",APSPLP,APSPORD)) Q:'APSPORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
..S ORD=APSPORD
..D:$P(^PS(52.41,APSPORD,0),U,3)'="DC"&($P(^(0),U,3)'="DE") PP^PSOORFIN,LK1^PSOORFIN,ORD^PSOORFIN Q
.S PSOFIN=1,X=PAT D ULP^PSOORFIN K PSOQQ
I $O(PSORX("PSOL",0))!($D(RXRS)) S PSODFN=+PSODFN D LBL^PSOORFIN ;MGH Get the last one
I $G(PSOQUIT) K PSOQUIT
D EX^PSOORFIN
M VALM=SAVE
D INIT
D RE^VALM4
S VALMBCK="R"
Q
; Toggle Orders/Patients
TOGORPT ;EP-
N PNM,IEN,PTOCNT,DFN,LD,RI
S PNM="" ;,LOCFLG=0
;Reset LOCFLG on when APSPORPT for patient list
;S LOCFLG=$S('APSPORPT:LOCFLG,1:0)
S (VALMCNT,PTOCNT,DFN)=0
D CLEAN^VALM10
;S APSPSORT="Patient Name"
S APSPSORT=$S(APSPORPT:"Patient Name",1:"Order Date")
D UPDCOL(APSPORPT)
I 'APSPORPT D
.;D CHGCAP^VALM("ORDDT","Order Date")
.S LD=0 F S LD=$O(^PS(52.41,"AD",LD)) Q:'LD D
..S RI=0 F S RI=$O(^PS(52.41,"AD",LD,RI)) Q:'RI D
...Q:(APSPINS'="*")&(RI'=APSPINS)
...S IEN=0 F S IEN=$O(^PS(52.41,"AD",LD,RI,IEN)) Q:'IEN D
....D:$L($G(^PS(52.41,IEN,0))) ADDITEM(IEN,APSPINS)
E D
.;D CHGCAP^VALM("ORDDT","Order Count")
.N LOCNM
.S LOCNM=""
.F S PNM=$O(^PS(52.41,"PN",PNM)) Q:PNM="" D I PTOCNT>0 D ADDPT(DFN,APSPINS,PTOCNT,LOCNM)
..S DFN=0,PTOCNT=0
..S IEN=0 F S IEN=$O(^PS(52.41,"PN",PNM,IEN)) Q:'IEN D
...Q:'$L($G(^PS(52.41,IEN,0)))
...Q:(APSPINS'="*")&(+$G(^PS(52.41,IEN,"INI"))'=APSPINS) ;check institution
...Q:"DEDC"[$P($G(^PS(52.41,IEN,0)),U,3) ;="DC" ;Discontinued or Discontinued (Edit)
...S PTOCNT=PTOCNT+1
...S LOCNM=$$GET1^DIQ(44,$P(^PS(52.41,IEN,0),U,13),.01)
...S:'DFN DFN=$P(^PS(52.41,IEN,0),U,2)
S VALMBCK="R"
I 'APSPFRST D
.D FIRST^VALM4
.D RE^VALM4
Q
; Add patient to array
ADDPT(DFN,INST,ORDCNT,LOCNM) ;EP-
N LINE,PTLOCK
;Exclude patient if LOCFLG enabled and not part of location array list.
Q:$$NOLOC(DFN)
S VALMCNT=VALMCNT+1
D UPDCOL(APSPORPT)
S LINE=$$SETFLD^VALM1(VALMCNT,"","ITEM")
S LINE=$$SETFLD^VALM1($$HRN^AUPNPAT(DFN,$S(INST:INST,1:DUZ(2))),LINE,"HRN")
S LINE=$$SETFLD^VALM1($S($$PTLOCK(DFN):"*",1:"")_$$GET1^DIQ(2,DFN,.01),LINE,"PATIENT")
S LINE=$$SETFLD^VALM1($$FMTE^XLFDT($$DOB^AUPNPAT(DFN),"5Z"),LINE,"DOB")
S LINE=$$SETFLD^VALM1(ORDCNT,LINE,"ORDDT")
S LINE=$$SETFLD^VALM1(LOCNM,LINE,"HOSPLOC")
D SETARR(VALMCNT,LINE,DFN)
Q
;Returns a 1 if patient lacks an order with location in APSPLOCS array when LOCFLG=1
NOLOC(DFN) ;EP-
N LP,RES
Q:'LOCFLG 0
S LP=0
F S LP=$O(APSPLOCS(LP)) Q:'LP D Q:RES
.S RES=''$D(^PS(52.41,"HLP",LP,DFN))
Q 'RES
; Build a patient array
BLDPTARY(ARY,LST,TYP) ;EP-
N ITM,POFIEN,DFN,IEN,VAL
F ITM=1:1:$L(LST,",") Q:$P(LST,",",ITM)']"" S VAL=$P(LST,",",ITM) D
.I TYP D
..S DFN=$P(@VALMAR@(VAL,"POFIEN"),U,2)
..Q:'DFN
..S ARY(DFN)=DFN
.E D
..S IEN=$P(@VALMAR@(VAL,"POFIEN"),U,2)
..Q:'IEN
..S DFN=$P($G(^PS(52.41,IEN,0)),U,2)
..Q:'DFN
..S ARY(DFN)=DFN
Q
; Update column headings
; Input- 0=Order 1=Patient
UPDCOL(MODE) ;EP-
D CHGCAP^VALM("ORDDT",$S(MODE:"Order Count",1:"Order Date"))
D CHGCAP^VALM("CFLG",$S(MODE:"",1:"C"))
D CHGCAP^VALM("COMMENT",$S(MODE:"",1:"Comment"))
Q
;
CHGCOM ;EP-
D CHGCOM^APSPCO1
Q
;
POST(Y) ;
N PSOFINY,VALM,VALMCNT,VALMAR,APSPDFN
S (APSPDFN,PSOFINY)=+$G(Y) D ^PSOBUILD S Y=$G(PSOFINY) K PSOFINY
M VALM=SAVE
;D OERR(APSPDFN)
Q:$G(PSOQFLG)
;S PSODFN=APSPDFN
S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
K PSOQFLG F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN K PSOXFLG Q:$G(POERR("DEAD"))!($G(PSOQFLG))
I $G(POERR("DEAD")) S POERR("QFLG")=1 Q
K PSOERR("DEAD") I $G(PSOQFLG) Q
D ^PSOORUT2
D BLD^PSOORUT1
D EN^PSOLMUTL
Q
;
OERR(Y) ;EP-Copied from PSORX1
N PSODFN,PSOQFLG,DFN,NOPROC,DIC,DR,DIQ,DA,PSOFIN,PSOLOUD,DIE,DLAYGO
N:$G(MEDP) PAT,POERR K PSOXFLG
S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
;K NPPROC,PSOQFLG,DIC,DR,DIQ
S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST"
D EN^DIQ1 K DIC,DA,DR,DIQ
D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
I $P($G(^PS(55,PSODFN,"LAN")),"^") W !,"Patient has another language preference!",! H 3
I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL^PSORX1
D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
I $G(PSOFIN) S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE
I '$D(^PS(55,PSODFN,0)) D
.S PSOPBM=$P(TM,".")
.K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
.L +^PS(55,PSODFN):0 I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q
.S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN
.;IHS/MSC/PB - 09/28/2012 - Remove other language field
.;S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
.S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
.W !!,"Patient Status Required!!",! D ELIG^PSORX1
.W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
.I $D(DIRUT)!(Y=-1) D Q
..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
..I $G(PSOPBM) D K PSOPBM
...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
.S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
.K DIRUT,DTOUT,DUOUT,X,Y,DA
Q:$G(PSOFIN)
I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".")
D ^PSOBUILD
F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2
K PSOERR("DEAD"),II
I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ
S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
D CLEAR^VALM1 M VALM=SAVE G:$G(PSOQUIT) PTX D EN^PSOLMAO
EOJ K PSOX,PSORXED
Q
PTX ;
K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR
Q
;
SELLLST ;EP-Supports the APSPCO LOC RESTRICT SEL protocol
;S LOCLLIEN=$$PMTLLST^APSPCO1()
D FULL^VALM1
D LOCARY
D LOCLST
Q
;
EDTLLST ;EP-Supports the APSPCO LOC RESTRICT EDIT protocol
D FULL^VALM1
D EDTLLST^APSPCO1
S VALMBCK="R"
Q
;
UPDLST ;EP- Updates list based on current criteria
D TOGORPT
Q
APSPCO ; IHS/MSC/PLS - List Manager Complete Orders ;24-Jul-2013 08:46;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1013,1014,1015,1016**;Sep 23, 2004;Build 74
+2 ; Modified - IHS/MSC/PB - 09/28/012 - OERR+26 to remove patient language flag
+3 ;=================================================================
+4 ;IHS/MSC/MGH Patch 1016 ADDITEM +2,6,11 Added visual for a flagged order
EN ; -- main entry point for APSP COMPLETE ORDERS
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
DO MSG^PSODPT
GOTO EX^PSOORFIN
+2 NEW APSPINS,APSPQ,LOCFLG,APSPLOCS,APSPSORT,APSPORPT
+3 NEW APSPPTAY,LOCLIEN,APSPFRST
+4 SET APSPQ=0
SET APSPINS=""
+5 SET APSPINS=$$DIR^APSPUTIL("Y","Would you like orders for all Ordering Institutions","Yes",,.APSPQ)
+6 IF APSPINS
Begin DoDot:1
+7 SET APSPINS="*"
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET APSPINS=$$GETIEN^APSPUTIL(4,"Select Ordering Institution: ",.APSPQ)
End DoDot:1
IF APSPQ
QUIT
+10 IF APSPQ
QUIT
+11 SET APSPFRST=1
+12 DO EN^VALM("APSP COMPLETE ORDERS")
+13 DO CLEAR^VALM1
+14 DO FULL^VALM1
+15 IF $DATA(IOF)
WRITE @IOF
+16 QUIT
+17 ;
HDR ; -- header code
+1 ;S XQORM("#")=$O(^ORD(101,"B","APSPCO PROCESS SELECT",0))_"^1:"_VALMCNT
+2 SET VALMHDR(1)="Outpatient Pharmacy Pending Orders"_" Related Institution: "_$SELECT(APSPINS:$$GET1^DIQ(4,APSPINS,.01),APSPINS="*":"ALL",1:" ")
+3 SET VALMHDR(2)="Sorted by: "_$GET(APSPSORT)_" Restrict to locations: "_$SELECT(LOCFLG:"ON for "_$$GET1^DIQ(9009033.6,$GET(LOCLIEN),.01),1:"OFF")
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 SET LOCFLG=$GET(LOCFLG,0)
+2 SET APSPORPT=$GET(APSPORPT,+$$GET^XPAR("ALL","APSPCO DEFAULT VIEW"))
+3 SET APSPSORT=$SELECT(APSPORPT:"Patient Name",1:"Order Date")
+4 DO CLEAN^VALM10
+5 DO BUILDLST(APSPINS)
+6 MERGE SAVE=VALM
+7 IF APSPFRST
SET APSPFRST=0
+8 QUIT
+9 ; Set line into array
SETARR(LINE,TEXT,IEN) ;EP-
+1 SET @VALMAR@(LINE,0)=TEXT
+2 IF $GET(IEN)
SET @VALMAR@("IDX",LINE,LINE)=""
+3 SET @VALMAR@(LINE,"POFIEN")=LINE_U_IEN
+4 QUIT
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL SAVE
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ; Build list of pending orders
BUILDLST(INST) ;EP-
+1 IF APSPORPT
DO TOGORPT
QUIT
+2 NEW LD,RI,IEN
+3 ;LOCFLG=0
SET VALMCNT=0
+4 ;D CHGCAP^VALM("ORDDT","Order Date")
+5 DO UPDCOL(APSPORPT)
+6 SET LD=0
FOR
SET LD=$ORDER(^PS(52.41,"AD",LD))
IF 'LD
QUIT
Begin DoDot:1
+7 SET RI=0
FOR
SET RI=$ORDER(^PS(52.41,"AD",LD,RI))
IF 'RI
QUIT
Begin DoDot:2
+8 IF (INST'="*")&(RI'=INST)
QUIT
+9 SET IEN=0
FOR
SET IEN=$ORDER(^PS(52.41,"AD",LD,RI,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+10 DO ADDITEM(IEN,INST)
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ; Add a single line item
ADDITEM(IEN,INST) ;EP-
+1 NEW NOD0,LINE,COM,PTLOCK,FLAG
+2 SET FLAG=0
+3 SET NOD0=$GET(^PS(52.41,IEN,0))
+4 IF 'NOD0
QUIT
+5 IF LOCFLG
IF '$DATA(APSPLOCS($PIECE(NOD0,U,13)))
QUIT
+6 IF $PIECE($GET(^PS(52.41,IEN,0)),"^",23)=1
SET FLAG=1
+7 SET VALMCNT=VALMCNT+1
+8 SET COM=$PIECE($GET(^PS(52.41,IEN,4)),U)
+9 SET LINE=$$SETFLD^VALM1(VALMCNT,"","ITEM")
+10 SET LINE=$$SETFLD^VALM1($$HRN^AUPNPAT($PIECE(NOD0,U,2),$SELECT(INST:INST,1:DUZ(2))),LINE,"HRN")
+11 SET LINE=$$SETFLD^VALM1($SELECT($$PTLOCK($PIECE(NOD0,U,2)):"*",1:"")_$$GET1^DIQ(2,$PIECE(NOD0,U,2),.01),LINE,"PATIENT")
+12 SET LINE=$$SETFLD^VALM1($$FMTE^XLFDT($$DOB^AUPNPAT($PIECE(NOD0,U,2)),"5Z"),LINE,"DOB")
+13 SET LINE=$$SETFLD^VALM1($SELECT($LENGTH(COM):"#",1:""),LINE,"CFLG")
+14 SET LINE=$$SETFLD^VALM1($TRANSLATE($$FMTE^XLFDT($EXTRACT($PIECE(NOD0,U,6),1,12),"5Z"),"@"," "),LINE,"ORDDT")
+15 SET LINE=$$SETFLD^VALM1($$GET1^DIQ(44,$PIECE(NOD0,U,13),.01),LINE,"HOSPLOC")
+16 ;S LINE=$$SETFLD^VALM1($P(NOD0,U),LINE,"ORDNUM")
+17 SET LINE=$$SETFLD^VALM1($SELECT($LENGTH(COM)>30:$EXTRACT(COM,1,27)_"...",1:COM),LINE,"COMMENT")
+18 IF FLAG=1
DO CNTRL^VALM10(VALMCNT,1,3,IORVON,IORVOFF,0)
+19 DO SETARR(VALMCNT,LINE,IEN)
+20 QUIT
+21 ; Return lock state of patient record
PTLOCK(DFN) ;EP-
+1 QUIT ''$GET(^XTMP("PSSLOCK",DFN))
+2 ;
LOCARY ;EP-
+1 NEW LOCARY,LP
+2 SET LOCLIEN=$$PMTLLST^APSPCO1()
+3 IF 'LOCLIEN
QUIT
+4 KILL APSPLOCS
+5 SET LP=0
+6 FOR
SET LP=$ORDER(^APSPLRS(9009033.6,LOCLIEN,1,LP))
IF 'LP
QUIT
Begin DoDot:1
+7 SET APSPLOCS(+^APSPLRS(9009033.6,LOCLIEN,1,LP,0))=""
End DoDot:1
+8 QUIT
+9 ; Build list of orders using location list
LOCLST ;EP-
+1 NEW LD,RI,IEN
+2 SET VALMCNT=0
+3 DO CLEAN^VALM10
+4 ;D CHGCAP^VALM("ORDDT","Order Date")
+5 DO UPDCOL(APSPORPT)
+6 SET LD=0
FOR
SET LD=$ORDER(^PS(52.41,"AD",LD))
IF 'LD
QUIT
Begin DoDot:1
+7 SET RI=0
FOR
SET RI=$ORDER(^PS(52.41,"AD",LD,RI))
IF 'RI
QUIT
Begin DoDot:2
+8 IF (APSPINS'="*")&(RI'=APSPINS)
QUIT
+9 SET IEN=0
FOR
SET IEN=$ORDER(^PS(52.41,"AD",LD,RI,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+10 DO ADDITEM(IEN,APSPINS)
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET VALMBCK="R"
+12 DO FIRST^VALM4
+13 DO RE^VALM4
+14 QUIT
+15 ; Custom sort list
SORTLST ;EP-
+1 NEW NARY,APSPQ,LP,CNT,NOD0,IDX,CL,IEN,POFIEN,SELITMS
+2 DO FULL^VALM1
+3 SET APSPQ=0
+4 SET CNT=0
+5 SET SELITMS="1:HRN;2:Patient Name;3:DOB;4:Order Date;5:Hospital Location"
+6 SET CL=+$$DIR^APSPUTIL("S^"_SELITMS,1,,.APSPQ)
+7 IF APSPQ
QUIT
+8 SET APSPSORT=$PIECE($PIECE(SELITMS,";",CL),":",2)
+9 SET LP=0
+10 FOR
SET LP=$ORDER(@VALMAR@(LP))
IF 'LP
QUIT
Begin DoDot:1
+11 SET POFIEN=$PIECE(@VALMAR@(LP,"POFIEN"),U,2)
+12 IF 'POFIEN
QUIT
+13 SET NOD0=$GET(^PS(52.41,POFIEN,0))
+14 IF 'NOD0
QUIT
+15 ;1:$P(NOD0,U,6))
SET IDX=$SELECT(CL=1:+$$HRN^AUPNPAT($PIECE(NOD0,U,2),$SELECT(APSPINS:APSPINS,1:DUZ(2))),CL=2:$$GET1^DIQ(2,$PIECE(NOD0,U,2),.01),CL=3:$$DOB^AUPNPAT($PIECE(NOD0,U,2)),CL=5:$$GET1^DIQ(44,$PIECE(NOD0,U,13),.01),1:$$SRTDT())
+16 SET CNT=CNT+1
+17 SET NARY("IDX",IDX,POFIEN)=""
End DoDot:1
+18 DO CLEAN^VALM10
+19 SET VALMCNT=0
+20 SET LP=""
+21 FOR
SET LP=$ORDER(NARY("IDX",LP))
IF '$LENGTH(LP)
QUIT
Begin DoDot:1
+22 SET IEN=0
+23 FOR
SET IEN=$ORDER(NARY("IDX",LP,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+24 DO ADDITEM(IEN,APSPINS)
End DoDot:2
End DoDot:1
+25 SET VALMBCK="R"
+26 DO FIRST^VALM4
+27 DO RE^VALM4
+28 QUIT
+29 ; Return sort date
SRTDT() ;EP-
+1 QUIT $SELECT($PIECE(NOD0,U,6):$PIECE(NOD0,U,6),$PIECE(NOD0,U,12):$PIECE(NOD0,U,12),1:$$NOW^XLFDT())
+2 ; Post message that patient record is locked
LOCCHK ;EP-
+1 NEW MSG,DFN,ITM,VAL
+2 SET MSG=""
SET VALMBCK=""
+3 DO EN^VALM2(XQORNOD(0),"SO")
+4 SET ITM=$ORDER(VALMY(""))
+5 IF 'ITM
QUIT
+6 SET VAL=$PIECE(@VALMAR@(ITM,"POFIEN"),U,2)
+7 IF 'VAL
QUIT
+8 IF 'APSPORPT
Begin DoDot:1
+9 SET DFN=$PIECE($GET(^PS(52.41,VAL,0)),U,2)
End DoDot:1
IF 'DFN
QUIT
+10 IF '$TEST
SET DFN=VAL
+11 IF $GET(^XTMP("PSSLOCK",DFN))
Begin DoDot:1
+12 SET MSG=$$WHO^PSSLOCK(DFN)
+13 SET MSG=$$GET1^DIQ(200,+$PIECE($GET(^XTMP("PSSLOCK",DFN)),U),.01)_" is editing orders ("_$$FMTE^XLFDT($EXTRACT($PIECE($GET(^XTMP("PSSLOCK",DFN)),U,2),1,12),"5Z")_")"
End DoDot:1
+14 SET VALMSG=$SELECT($LENGTH(MSG):MSG,1:"This patient is available for processing.")
+15 QUIT
+16 ;
SELORD ;
+1 NEW Y
+2 SET Y=$PIECE(XQORNOD(0),"=",2)
+3 DO PROC1
+4 QUIT
+5 ; Process patient orders
PROCESS ;EP-
+1 NEW DIR,DUOUT,DIRUT,Y
+2 SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_VALMCNT
DO ^DIR
+3 IF $DATA(DIRUT)!$DATA(DUOUT)
SET VALMBCK="R"
QUIT
PROC1 ;EP-
+1 NEW SAVEPAT,LASTDFN,APSPORD,LST,APSPLP,PSODFN,PAT,PSOLK
+2 NEW MEDA,PSOFIN,X,MEDP,PATA,ORD
+3 KILL APSPPTAY
+4 SET SAVEPAT=""
+5 IF +Y
DO FULL^VALM1
SET LST=Y
+6 DO BLDPTARY(.APSPPTAY,LST,APSPORPT)
+7 SET LASTDFN=0
+8 SET APSPLP=0
FOR
SET APSPLP=$ORDER(APSPPTAY(APSPLP))
IF 'APSPLP
QUIT
Begin DoDot:1
+9 NEW VALM,VALMPGE
+10 IF SAVEPAT'=APSPLP
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
Begin DoDot:2
+11 NEW ZP
+12 SET ZP=PSODFN
+13 ;MGH ADD
SET PSODFN=+PSODFN
DO LBL^PSOORFIN
+14 SET PSODFN=ZP
End DoDot:2
+15 SET (PAT,SAVEPAT)=APSPLP
+16 IF '$DATA(^PS(52.41,"P",PAT))
Begin DoDot:2
+17 WRITE !,"The orders for this patient have already been processed!"
End DoDot:2
+18 DO LK^PSOORFIN
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
QUIT
+19 IF $$CHK^PSODPT(PAT_U_$PIECE($GET(^DPT(PAT,0)),U),1,1)<0
SET PSOLK=1
SET X=PAT
DO ULP^PSOORFIN
KILL PSOQFLG,PSOQQ
QUIT
+20 SET (PSODFN,Y)=PAT_U_$PIECE($GET(^DPT(PAT,0)),U)
+21 SET (PATA,LASTDFN)=+PSODFN
+22 DO SETPTCX^APSPFUNC(+PSODFN)
+23 IF '$GET(MEDA)
DO PROFILE^PSOORFI2
MERGE VALM=SAVE
+24 SET Y=PSODFN
+25 IF $GET(MEDP)
Begin DoDot:2
+26 DO SPL^PSOORFIN
DO OERR(Y)
SET PSOFIN=1
DO QU^PSOORFIN
SET X=PSOPTLOK
DO KLLP^PSOORFIN
DO ULP^PSOORFIN
DO KLL^PSOORFIN
End DoDot:2
QUIT
+27 DO SDFN^PSOORFIN
+28 DO POST(Y)
+29 IF $GET(PSOQFLG)!($GET(PSOQUIT))
IF $GET(PSOQUIT)
SET POERR("QFLG")=1
SET X=SAVEPAT
DO ULP^PSOORFIN
KILL PSOQFLG
QUIT
+30 SET APSPORD=0
FOR
SET APSPORD=$ORDER(^PS(52.41,"P",APSPLP,APSPORD))
IF 'APSPORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
QUIT
Begin DoDot:2
+31 SET ORD=APSPORD
+32 IF $PIECE(^PS(52.41,APSPORD,0),U,3)'="DC"&($PIECE(^(0),U,3)'="DE")
DO PP^PSOORFIN
DO LK1^PSOORFIN
DO ORD^PSOORFIN
QUIT
End DoDot:2
+33 SET PSOFIN=1
SET X=PAT
DO ULP^PSOORFIN
KILL PSOQQ
End DoDot:1
+34 ;MGH Get the last one
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
SET PSODFN=+PSODFN
DO LBL^PSOORFIN
+35 IF $GET(PSOQUIT)
KILL PSOQUIT
+36 DO EX^PSOORFIN
+37 MERGE VALM=SAVE
+38 DO INIT
+39 DO RE^VALM4
+40 SET VALMBCK="R"
+41 QUIT
+42 ; Toggle Orders/Patients
TOGORPT ;EP-
+1 NEW PNM,IEN,PTOCNT,DFN,LD,RI
+2 ;,LOCFLG=0
SET PNM=""
+3 ;Reset LOCFLG on when APSPORPT for patient list
+4 ;S LOCFLG=$S('APSPORPT:LOCFLG,1:0)
+5 SET (VALMCNT,PTOCNT,DFN)=0
+6 DO CLEAN^VALM10
+7 ;S APSPSORT="Patient Name"
+8 SET APSPSORT=$SELECT(APSPORPT:"Patient Name",1:"Order Date")
+9 DO UPDCOL(APSPORPT)
+10 IF 'APSPORPT
Begin DoDot:1
+11 ;D CHGCAP^VALM("ORDDT","Order Date")
+12 SET LD=0
FOR
SET LD=$ORDER(^PS(52.41,"AD",LD))
IF 'LD
QUIT
Begin DoDot:2
+13 SET RI=0
FOR
SET RI=$ORDER(^PS(52.41,"AD",LD,RI))
IF 'RI
QUIT
Begin DoDot:3
+14 IF (APSPINS'="*")&(RI'=APSPINS)
QUIT
+15 SET IEN=0
FOR
SET IEN=$ORDER(^PS(52.41,"AD",LD,RI,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+16 IF $LENGTH($GET(^PS(52.41,IEN,0)))
DO ADDITEM(IEN,APSPINS)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 ;D CHGCAP^VALM("ORDDT","Order Count")
+19 NEW LOCNM
+20 SET LOCNM=""
+21 FOR
SET PNM=$ORDER(^PS(52.41,"PN",PNM))
IF PNM=""
QUIT
Begin DoDot:2
+22 SET DFN=0
SET PTOCNT=0
+23 SET IEN=0
FOR
SET IEN=$ORDER(^PS(52.41,"PN",PNM,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+24 IF '$LENGTH($GET(^PS(52.41,IEN,0)))
QUIT
+25 ;check institution
IF (APSPINS'="*")&(+$GET(^PS(52.41,IEN,"INI"))'=APSPINS)
QUIT
+26 ;="DC" ;Discontinued or Discontinued (Edit)
IF "DEDC"[$PIECE($GET(^PS(52.41,IEN,0)),U,3)
QUIT
+27 SET PTOCNT=PTOCNT+1
+28 SET LOCNM=$$GET1^DIQ(44,$PIECE(^PS(52.41,IEN,0),U,13),.01)
+29 IF 'DFN
SET DFN=$PIECE(^PS(52.41,IEN,0),U,2)
End DoDot:3
End DoDot:2
IF PTOCNT>0
DO ADDPT(DFN,APSPINS,PTOCNT,LOCNM)
End DoDot:1
+30 SET VALMBCK="R"
+31 IF 'APSPFRST
Begin DoDot:1
+32 DO FIRST^VALM4
+33 DO RE^VALM4
End DoDot:1
+34 QUIT
+35 ; Add patient to array
ADDPT(DFN,INST,ORDCNT,LOCNM) ;EP-
+1 NEW LINE,PTLOCK
+2 ;Exclude patient if LOCFLG enabled and not part of location array list.
+3 IF $$NOLOC(DFN)
QUIT
+4 SET VALMCNT=VALMCNT+1
+5 DO UPDCOL(APSPORPT)
+6 SET LINE=$$SETFLD^VALM1(VALMCNT,"","ITEM")
+7 SET LINE=$$SETFLD^VALM1($$HRN^AUPNPAT(DFN,$SELECT(INST:INST,1:DUZ(2))),LINE,"HRN")
+8 SET LINE=$$SETFLD^VALM1($SELECT($$PTLOCK(DFN):"*",1:"")_$$GET1^DIQ(2,DFN,.01),LINE,"PATIENT")
+9 SET LINE=$$SETFLD^VALM1($$FMTE^XLFDT($$DOB^AUPNPAT(DFN),"5Z"),LINE,"DOB")
+10 SET LINE=$$SETFLD^VALM1(ORDCNT,LINE,"ORDDT")
+11 SET LINE=$$SETFLD^VALM1(LOCNM,LINE,"HOSPLOC")
+12 DO SETARR(VALMCNT,LINE,DFN)
+13 QUIT
+14 ;Returns a 1 if patient lacks an order with location in APSPLOCS array when LOCFLG=1
NOLOC(DFN) ;EP-
+1 NEW LP,RES
+2 IF 'LOCFLG
QUIT 0
+3 SET LP=0
+4 FOR
SET LP=$ORDER(APSPLOCS(LP))
IF 'LP
QUIT
Begin DoDot:1
+5 SET RES=''$DATA(^PS(52.41,"HLP",LP,DFN))
End DoDot:1
IF RES
QUIT
+6 QUIT 'RES
+7 ; Build a patient array
BLDPTARY(ARY,LST,TYP) ;EP-
+1 NEW ITM,POFIEN,DFN,IEN,VAL
+2 FOR ITM=1:1:$LENGTH(LST,",")
IF $PIECE(LST,",",ITM)']""
QUIT
SET VAL=$PIECE(LST,",",ITM)
Begin DoDot:1
+3 IF TYP
Begin DoDot:2
+4 SET DFN=$PIECE(@VALMAR@(VAL,"POFIEN"),U,2)
+5 IF 'DFN
QUIT
+6 SET ARY(DFN)=DFN
End DoDot:2
+7 IF '$TEST
Begin DoDot:2
+8 SET IEN=$PIECE(@VALMAR@(VAL,"POFIEN"),U,2)
+9 IF 'IEN
QUIT
+10 SET DFN=$PIECE($GET(^PS(52.41,IEN,0)),U,2)
+11 IF 'DFN
QUIT
+12 SET ARY(DFN)=DFN
End DoDot:2
End DoDot:1
+13 QUIT
+14 ; Update column headings
+15 ; Input- 0=Order 1=Patient
UPDCOL(MODE) ;EP-
+1 DO CHGCAP^VALM("ORDDT",$SELECT(MODE:"Order Count",1:"Order Date"))
+2 DO CHGCAP^VALM("CFLG",$SELECT(MODE:"",1:"C"))
+3 DO CHGCAP^VALM("COMMENT",$SELECT(MODE:"",1:"Comment"))
+4 QUIT
+5 ;
CHGCOM ;EP-
+1 DO CHGCOM^APSPCO1
+2 QUIT
+3 ;
POST(Y) ;
+1 NEW PSOFINY,VALM,VALMCNT,VALMAR,APSPDFN
+2 SET (APSPDFN,PSOFINY)=+$GET(Y)
DO ^PSOBUILD
SET Y=$GET(PSOFINY)
KILL PSOFINY
+3 MERGE VALM=SAVE
+4 ;D OERR(APSPDFN)
+5 IF $GET(PSOQFLG)
QUIT
+6 ;S PSODFN=APSPDFN
+7 SET (DFN,PSODFN)=+Y
SET PSORX("NAME")=$PIECE(Y,"^",2)
+8 KILL PSOQFLG
FOR PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY"
SET RTN=PT_"^PSOPTPST"
DO @RTN
KILL PSOXFLG
IF $GET(POERR("DEAD"))!($GET(PSOQFLG))
QUIT
+9 IF $GET(POERR("DEAD"))
SET POERR("QFLG")=1
QUIT
+10 KILL PSOERR("DEAD")
IF $GET(PSOQFLG)
QUIT
+11 DO ^PSOORUT2
+12 DO BLD^PSOORUT1
+13 DO EN^PSOLMUTL
+14 QUIT
+15 ;
OERR(Y) ;EP-Copied from PSORX1
+1 NEW PSODFN,PSOQFLG,DFN,NOPROC,DIC,DR,DIQ,DA,PSOFIN,PSOLOUD,DIE,DLAYGO
+2 IF $GET(MEDP)
NEW PAT,POERR
KILL PSOXFLG
+3 SET (DFN,PSODFN)=+Y
SET PSORX("NAME")=$PIECE(Y,"^",2)
+4 ;K NPPROC,PSOQFLG,DIC,DR,DIQ
+5 SET DIC=2
SET DA=PSODFN
SET DR=.351
SET DIQ="PSOPTPST"
+6 DO EN^DIQ1
KILL DIC,DA,DR,DIQ
+7 DO DEAD^PSOPTPST
IF $GET(PSOQFLG)
SET NOPROC=1
QUIT
+8 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
WRITE !,"Patient has another language preference!",!
HANG 3
+9 IF $GET(^PS(55,"ASTALK",PSODFN))
WRITE !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",!
HANG 2
DO MAIL^PSORX1
+10 DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
+11 IF '$GET(MEDP)
SET X="PPPPDA1"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=$$PDA^PPPPDA1(PSODFN)
+12 SET PSOQFLG=0
SET DIC="^PS(55,"
SET DLAYGO=55
+13 IF $GET(PSOFIN)
SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
WRITE !!?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")"
KILL SSN
+14 ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE
KILL PSOPBM
+15 IF '$DATA(^PS(55,PSODFN,0))
Begin DoDot:1
+16 SET PSOPBM=$PIECE(TM,".")
+17 KILL DD,DO
SET DIC(0)="L"
SET (DINUM,X)=PSODFN
DO FILE^DICN
IF Y<1
Begin DoDot:2
+18 SET $PIECE(^PS(55,PSODFN,0),"^")=PSODFN
KILL DIK
SET DA=PSODFN
SET DIK="^PS(55,"
SET DIK(1)=.01
DO EN^DIK
KILL DIK
End DoDot:2
KILL DIC,DA,DR,DD,DO
End DoDot:1
+19 SET PSOLOUD=1
IF $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+20 IF $GET(^PS(55,PSODFN,"PS"))']""
Begin DoDot:1
+21 LOCK +^PS(55,PSODFN):0
IF '$TEST
WRITE $CHAR(7),!!,"Patient Data is Being Edited by Another User!",!
SET POERR("QFLG")=1
IF $GET(PSOFIN)
SET PSOQUIT=1
QUIT
+22 SET PSOXFLG=1
SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
WRITE !!?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")",!
KILL SSN
+23 ;IHS/MSC/PB - 09/28/2012 - Remove other language field
+24 ;S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
+25 SET DIE=55
SET DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106.1"
SET DA=PSODFN
WRITE !!,?5,">>PHARMACY PATIENT DATA<<",!
DO ^DIE
LOCK -^PS(55,PSODFN)
End DoDot:1
IF $GET(POERR("QFLG"))
GOTO EOJ
+26 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
+27 IF $GET(^PS(55,PSODFN,"PS"))']""
Begin DoDot:1
+28 WRITE !!,"Patient Status Required!!",!
DO ELIG^PSORX1
+29 WRITE !
KILL POERR("QFLG"),DIC,DR,DIE
SET DIC("A")="PATIENT STATUS: "
SET DIC(0)="QEAMZ"
SET DIC=53
DO ^DIC
KILL DIC
+30 IF $DATA(DIRUT)!(Y=-1)
Begin DoDot:2
+31 WRITE $CHAR(7),"Required Data!",!
SET POERR("QFLG")=1
IF $GET(PSOFIN)
SET PSOQUIT=1
+32 IF $GET(PSOPBM)
Begin DoDot:3
+33 IF $ORDER(^PS(55,PSODFN,0))=""
SET DA=PSODFN
SET DIK="^PS(55,"
DO ^DIK
End DoDot:3
KILL PSOPBM
End DoDot:2
QUIT
+34 SET ^PS(55,PSODFN,"PS")=+Y
SET PSORX("PATIENT STATUS")=$PIECE(^PS(53,+Y,0),"^")
+35 KILL DIRUT,DTOUT,DUOUT,X,Y,DA
End DoDot:1
IF $GET(POERR("QFLG"))
GOTO EOJ
+36 IF $GET(PSOFIN)
QUIT
+37 IF '$GET(PSOPBM)
IF '$PIECE(^PS(55,PSODFN,0),"^",7)
IF $PIECE(^(0),"^",8)']""
SET PSOPBM=$PIECE(TM,".")
+38 DO ^PSOBUILD
+39 FOR PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY"
SET RTN=PT_"^PSOPTPST"
DO @RTN
IF $GET(POERR("DEAD"))!($GET(PSOQFLG))
QUIT
+40 IF $GET(POERR("DEAD"))
SET POERR("QFLG")=1
FOR II=0:0
SET II=$ORDER(^PS(52.41,"P",PSODFN,II))
IF $PIECE($GET(^PS(52.41,II,0)),"^",3)'="DC"&($PIECE($GET(^(0)),"^",3)'="DE")
DO DC^PSOORFI2
+41 KILL PSOERR("DEAD"),II
+42 IF $GET(PSOQFLG)
SET POERR("QFLG")=1
GOTO EOJ
+43 SET (PAT,PSOXXDFN)=PSODFN
SET POERR=1
DO ^PSOORUT2
DO BLD^PSOORUT1
DO EN^PSOLMUTL
+44 DO CLEAR^VALM1
MERGE VALM=SAVE
IF $GET(PSOQUIT)
GOTO PTX
DO EN^PSOLMAO
EOJ KILL PSOX,PSORXED
+1 QUIT
PTX ;
+1 KILL X,Y,^TMP("PS",$JOB),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR
+2 QUIT
+3 ;
SELLLST ;EP-Supports the APSPCO LOC RESTRICT SEL protocol
+1 ;S LOCLLIEN=$$PMTLLST^APSPCO1()
+2 DO FULL^VALM1
+3 DO LOCARY
+4 DO LOCLST
+5 QUIT
+6 ;
EDTLLST ;EP-Supports the APSPCO LOC RESTRICT EDIT protocol
+1 DO FULL^VALM1
+2 DO EDTLLST^APSPCO1
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
UPDLST ;EP- Updates list based on current criteria
+1 DO TOGORPT
+2 QUIT
