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

PSJBCMA3.m

Go to the documentation of this file.
  1. PSJBCMA3 ;BIR/JLC-ADD BCMA STATUS UPDATE TO PS(55 ;21 FEB 01
  1. ;;5.0;INPATIENT MEDICATIONS ;**58,91,190,347,400**;16 DEC 97;Build 2
  1. ;Reference to ^PS(51.1 is supported by DBIA #2177.
  1. ;Reference to ^PS(55 is supported by DBIA 2191
  1. ;
  1. EN(DFN,ON,BCID,STATUS,DATE) ;
  1. I '$D(DFN)!'$D(ON)!'$D(BCID)!'$D(STATUS)!'$D(DATE) Q
  1. I '$D(^PS(55,DFN,"IV",ON)) Q
  1. N PSJBLN,UON
  1. D SEARCH(ON)
  1. I $D(PSJBLN) S UON=ON G UPDATE
  1. S (PON,OPON)=ON F S PON=$P(^PS(55,DFN,"IV",PON,2),"^",5) S:PON["P" PON=$$PNDV(PON) S PON=+PON Q:'PON Q:PON=OPON D SEARCH(PON) Q:$D(PSJBLN) S OPON=PON
  1. I $D(PSJBLN) S UON=PON G UPDATE
  1. Q
  1. Q
  1. UPDATE K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IVBCMA"",",DA=PSJBLN,DA(1)=DFN,DR="1////"_DATE_";2////"_STATUS
  1. I STATUS="" S DR="1///@;2///@"
  1. D ^DIE
  1. K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA=UON,DA(1)=DFN,DR="144////"_STATUS_";145////"_BCID
  1. I STATUS="" S DR="144///@;145///@"
  1. D ^DIE
  1. Q
  1. ;
  1. PNDV(PNDON) ;
  1. Q:PNDON'["P" ""
  1. N PRV S PRV=""
  1. F S PRV=$P($G(^PS(53.1,+PNDON,0)),"^",25) Q:PRV=""!(PRV["V") S PNDON=PRV
  1. Q $S(PRV["V":PRV,1:"")
  1. ;
  1. OTPRN(SCH1) ; Determine if this order is a one-time PRN PSJ*5*190
  1. N SCH2 S TYP=""
  1. ;actual schedule of "x PRN" exists in schedule file. Don't remove PRN from it.
  1. I $D(^PS(51.1,"AC","PSJ",SCH1)) D Q $G(TYP)
  1. .S SCH2=$O(^PS(51.1,"AC","PSJ",SCH1,"")) Q:'$D(^PS(51.1,SCH2)) ; p400 changed from Q:'$D(^PS(53.1,SCH2))
  1. .S TYP=$P($G(^PS(51.1,SCH2,0)),"^",5)
  1. S SCH1=$P(SCH1," PRN",1)
  1. I SCH1="" Q ""
  1. I '$D(^PS(51.1,"AC","PSJ",SCH1)) Q ""
  1. S SCH2=$O(^PS(51.1,"AC","PSJ",SCH1,""))
  1. I '$D(^PS(51.1,SCH2)) Q ""
  1. Q $P($G(^PS(51.1,SCH2,0)),"^",5)