source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMEDS.m@ 1061

PSJMEDS ;BIR/MV-FIND PATIENT INFO FOR SPECIFIC WARD ;07 Jul 98 / 4:05 PM
 ;;5.0; INPATIENT MEDICATIONS ;**34,111**;16 DEC 97
 ;
 ; Reference to ^PS(51.2 is supported by DBIA #2178
 ; Reference to ^PS(55 is supported by DBIA# 2191
 ;
WARDGP ;*** Find wards within a ward group
 S PSGWD="",TM="ZZ" F  S PSGWD=$O(^PS(57.5,"AC",PSGWG,PSGWD)) Q:'PSGWD  I $D(^DIC(42,+PSGWD,0)) S PSGWN=$P(^(0),U) D WARD
 Q:PSGWG'="^OTHER"
 N STDTE
 S PSGSS="G",PSJACNWP=""
 S STDTE=0 F  S STDTE=$O(^PS(55,"AUDC",STDTE)) Q:'STDTE  S CLINIC=0 F  S CLINIC=$O(^PS(55,"AUDC",STDTE,CLINIC)) Q:'CLINIC  D
 . S JDFN=0 F  S JDFN=$O(^PS(55,"AUDC",STDTE,CLINIC,JDFN)) Q:'JDFN  S PSGP=JDFN D ^PSJAC S PPN=PSGP(0) D MEDTYPE
 S STDTE=0 F  S STDTE=$O(^PS(55,"AIVC",STDTE)) Q:'STDTE  S CLINIC=0 F  S CLINIC=$O(^PS(55,"AIVC",STDTE,CLINIC)) Q:'CLINIC  D
 . S JDFN=0 F  S JDFN=$O(^PS(55,"AIVC",STDTE,CLINIC,JDFN)) Q:'JDFN  S PSGP=JDFN D ^PSJAC S PPN=PSGP(0) D MEDTYPE
 Q
 ;
WARD ;*** Go through each patient within a given WARD
 ;*** Var used in PSJAC. Set to null to skip WP^PSJAC
 ;
 S PSJACNWP=""
 F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGWN,PSGP)) Q:'PSGP  D ^PSJAC S PPN=PSGP(0) D:PSGSS="W" TEAM D:PSGSS="G" MEDTYPE
 Q
 ;
TEAM ;*** Look up selected team.  PSGTMALL= All teams were selected.
 ;
 S TM="ZZ"
 I PSGTMALL D ALLTM,MEDTYPE Q
 I 'PSGTM D MEDTYPE Q
 I PSGTM,'PSGTMALL S TM="",RBNO=0 F  S TM=$O(PSGTM(TM)) Q:TM=""  S TMNO=PSGTM(TM) S:$G(PSJPRB) RBNO=$O(^PS(57.7,"AWRT",PSGWD,PSJPRB,TMNO,0)) D:RBNO MEDTYPE
 Q
 ;
ALLTM ;*** Get UNIT DOSE information from ^PS(55
 ;
 S TM=$S(PSJPRB="":0,1:+$O(^PS(57.7,"AWRT",PSGWD,PSJPRB,0))),TM=$S('$G(TM):"ZZ",'$D(^PS(57.7,PSGWD,1,TM,0)):TM,$P(^(0),U)]"":$P(^(0),U),1:TM)
 Q
 ;
MEDTYPE ;
 S:PSJPRB="" PSJPRB="NOT FOUND"
 I PSGMTYPE[1 F XTYPE=2:1:6 D LOOP(XTYPE)
 I PSGMTYPE'[1 F XTYPE=2:1:6 D:PSGMTYPE[XTYPE LOOP(XTYPE)
 D ^PSJMPEND
 Q
 ;
LOOP(XTYPE) ;*** Loop through stop date cross ref. to find unit dose nodes
 I XTYPE=2  F PST="C","O","OC","P","R"  F PSGEXPDT=PSGPLS-.0001:0 S PSGEXPDT=$O(^PS(55,PSGP,5,"AU",PST,PSGEXPDT)) Q:'PSGEXPDT  D
 . F ON=0:0 S ON=$O(^PS(55,PSGP,5,"AU",PST,PSGEXPDT,ON)) Q:'ON  D UDOSE
 I XTYPE=2 S PST="S" D ^PSJMIV
 I XTYPE>2 S PST=$S(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",XTYPE=6:"C") D ^PSJMIV
 I XTYPE=3 S PST="S" D ^PSJMIV
 Q
 ;
UDOSE ;
 ;*** Check on status for Hold,Discontinue,Expired,DE(discontinue Edit)
 S UD0=$G(^PS(55,PSGP,5,ON,0)) Q:"DE"[$P(UD0,U,9)
 S UD2=$G(^PS(55,PSGP,5,ON,2))  Q:$P(UD2,U,2)>PSGPLF
 ;
 ;*** Setup drug info
 S DRG=$E($$ENPDN^PSGMI(+$G(^PS(55,PSGP,5,ON,.2))),1,20)_U_ON,PSJDOS=$P($G(^PS(55,PSGP,5,ON,.2)),U,2)
 I $P($G(^PS(51.2,+$P(UD0,U,3),0)),U)]"" S PSJMR=$E($S($P(^(0),U,3)]"":$P(^(0),U,3),1:$P(^(0),U)),1,5)
 S PSJSCHE=$P(UD2,U),QST=$S(PSJSCHE["PRN":"P",1:PST)
 S PSGLOD=$P(UD0,U,14),PSGLSD=$P(UD2,U,2),PSGLFD=$P(UD2,U,4)
 Q:('PSJMPRN&(QST="P"))
 S PSJSI=$S($P(UD0,U,22):"*** NOT TO BE GIVEN ***",1:$P($G(^PS(55,PSGP,5,ON,6)),U))
 S PSJHOLD=$S($P(UD0,U,9)["H":1,1:0)
 D:QST'="P" ADMIN
 I QST="P" S PSJATME=9999,PSJADT=9999999 D @PSGSS
 Q
 ;
ADMIN ;
 S PSGPLO=ON,PSGMFOR="" D ^PSJPL0
 I PSJPLC=1 S PSJATME=8888,PSJADT=8888888 D @PSGSS
 F ADMIN=0:0 S ADMIN=$O(PSGMAR(ADMIN)) Q:'ADMIN  S PSJADT=$P(ADMIN,"."),PSJATME=+$E($P(ADMIN,".",2)_"0000",1,4) D @PSGSS
 Q
 ;
P ;*** Set up ^TMP for sort by patients
 NEW QST S QST=$S("CO"[PST:PST,PST="OC":"OA",1:"CR")
 S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
 S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
 S ^TMP($J,QST,PSGP,ON,1)=PSJSI
 Q
 ;
G ;*** Goto W to set up ^TMP when print by WARD/WARD GROUP
 ;
W ;*** Set up ^TMP when listing by ward
 S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
 S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
 S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
 S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
 S ^TMP($J,QST,PSGP,ON,1)=PSJSI
 Q