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

APSPCO.m

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