Routine: PSJMEDS

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

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

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

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)

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

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

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

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

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

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

PSJMEDS   ;BIR/MV-FIND PATIENT INFO FOR SPECIFIC WARD ;07 Jul 98 / 4:05 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**34,111**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(51.2 is supported by DBIA #2178

 +4       ; Reference to ^PS(55 is supported by DBIA# 2191

 +5       ;

WARDGP    ;*** Find wards within a ward group

 +1        SET PSGWD=""

           SET TM="ZZ"

FOR

               SET PSGWD=$ORDER(^PS(57.5,"AC",PSGWG,PSGWD))

               IF 'PSGWD

                   QUIT

               IF $DATA(^DIC(42,+PSGWD,0))

                   SET PSGWN=$PIECE(^(0),U)

                   DO WARD

 +2        IF PSGWG'="^OTHER"

               QUIT

 +3        NEW STDTE

 +4        SET PSGSS="G"

           SET PSJACNWP=""

 +5        SET STDTE=0

FOR

               SET STDTE=$ORDER(^PS(55,"AUDC",STDTE))

               IF 'STDTE

                   QUIT

               SET CLINIC=0

FOR

                   SET CLINIC=$ORDER(^PS(55,"AUDC",STDTE,CLINIC))

                   IF 'CLINIC

                       QUIT

                   Begin DoDot:1

 +6                    SET JDFN=0

FOR

                           SET JDFN=$ORDER(^PS(55,"AUDC",STDTE,CLINIC,JDFN))

                           IF 'JDFN

                               QUIT

                           SET PSGP=JDFN

                           DO ^PSJAC

                           SET PPN=PSGP(0)

                           DO MEDTYPE

                   End DoDot:1

 +7        SET STDTE=0

FOR

               SET STDTE=$ORDER(^PS(55,"AIVC",STDTE))

               IF 'STDTE

                   QUIT

               SET CLINIC=0

FOR

                   SET CLINIC=$ORDER(^PS(55,"AIVC",STDTE,CLINIC))

                   IF 'CLINIC

                       QUIT

                   Begin DoDot:1

 +8                    SET JDFN=0

FOR

                           SET JDFN=$ORDER(^PS(55,"AIVC",STDTE,CLINIC,JDFN))

                           IF 'JDFN

                               QUIT

                           SET PSGP=JDFN

                           DO ^PSJAC

                           SET PPN=PSGP(0)

                           DO MEDTYPE

                   End DoDot:1

 +9        QUIT

 +10      ;

WARD      ;*** Go through each patient within a given WARD

 +1       ;*** Var used in PSJAC. Set to null to skip WP^PSJAC

 +2       ;

 +3        SET PSJACNWP=""

 +4        FOR PSGP=0:0

               SET PSGP=$ORDER(^DPT("CN",PSGWN,PSGP))

               IF 'PSGP

                   QUIT

               DO ^PSJAC

               SET PPN=PSGP(0)

               IF PSGSS="W"

                   DO TEAM

               IF PSGSS="G"

                   DO MEDTYPE

 +5        QUIT

 +6       ;

TEAM      ;*** Look up selected team.  PSGTMALL= All teams were selected.

 +1       ;

 +2        SET TM="ZZ"

 +3        IF PSGTMALL

               DO ALLTM

               DO MEDTYPE

               QUIT

 +4        IF 'PSGTM

               DO MEDTYPE

               QUIT

 +5        IF PSGTM

               IF 'PSGTMALL

                   SET TM=""

                   SET RBNO=0

FOR

                       SET TM=$ORDER(PSGTM(TM))

                       IF TM=""

                           QUIT

                       SET TMNO=PSGTM(TM)

                       IF $GET(PSJPRB)

                           SET RBNO=$ORDER(^PS(57.7,"AWRT",PSGWD,PSJPRB,TMNO,0))

                       IF RBNO

                           DO MEDTYPE

 +6        QUIT

 +7       ;

ALLTM     ;*** Get UNIT DOSE information from ^PS(55

 +1       ;

 +2        SET TM=$SELECT(PSJPRB="":0,1:+$ORDER(^PS(57.7,"AWRT",PSGWD,PSJPRB,0)))

           SET TM=$SELECT('$GET(TM):"ZZ",'$DATA(^PS(57.7,PSGWD,1,TM,0)):TM,$PIECE(^(0),U)]"":$PIECE(^(0),U),1:TM)

 +3        QUIT

 +4       ;

MEDTYPE   ;

 +1        IF PSJPRB=""

               SET PSJPRB="NOT FOUND"

 +2        IF PSGMTYPE[1

               FOR XTYPE=2:1:6

                   DO LOOP(XTYPE)

 +3        IF PSGMTYPE'[1

               FOR XTYPE=2:1:6

                   IF PSGMTYPE[XTYPE

                       DO LOOP(XTYPE)

 +4        DO ^PSJMPEND

 +5        QUIT

 +6       ;

LOOP(XTYPE) ;*** Loop through stop date cross ref. to find unit dose nodes

 +1        IF XTYPE=2

               FOR PST="C","O","OC","P","R"

                   FOR PSGEXPDT=PSGPLS-.0001:0

                       SET PSGEXPDT=$ORDER(^PS(55,PSGP,5,"AU",PST,PSGEXPDT))

                       IF 'PSGEXPDT

                           QUIT

                       Begin DoDot:1

 +2                        FOR ON=0:0

                               SET ON=$ORDER(^PS(55,PSGP,5,"AU",PST,PSGEXPDT,ON))

                               IF 'ON

                                   QUIT

                               DO UDOSE

                       End DoDot:1

 +3        IF XTYPE=2

               SET PST="S"

               DO ^PSJMIV

 +4        IF XTYPE>2

               SET PST=$SELECT(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",XTYPE=6:"C")

               DO ^PSJMIV

 +5        IF XTYPE=3

               SET PST="S"

               DO ^PSJMIV

 +6        QUIT

 +7       ;

UDOSE     ;

 +1       ;*** Check on status for Hold,Discontinue,Expired,DE(discontinue Edit)

 +2        SET UD0=$GET(^PS(55,PSGP,5,ON,0))

           IF "DE"[$PIECE(UD0,U,9)

               QUIT

 +3        SET UD2=$GET(^PS(55,PSGP,5,ON,2))

           IF $PIECE(UD2,U,2)>PSGPLF

               QUIT

 +4       ;

 +5       ;*** Setup drug info

 +6        SET DRG=$EXTRACT($$ENPDN^PSGMI(+$GET(^PS(55,PSGP,5,ON,.2))),1,20)_U_ON

           SET PSJDOS=$PIECE($GET(^PS(55,PSGP,5,ON,.2)),U,2)

 +7        IF $PIECE($GET(^PS(51.2,+$PIECE(UD0,U,3),0)),U)]""

               SET PSJMR=$EXTRACT($SELECT($PIECE(^(0),U,3)]"":$PIECE(^(0),U,3),1:$PIECE(^(0),U)),1,5)

 +8        SET PSJSCHE=$PIECE(UD2,U)

           SET QST=$SELECT(PSJSCHE["PRN":"P",1:PST)

 +9        SET PSGLOD=$PIECE(UD0,U,14)

           SET PSGLSD=$PIECE(UD2,U,2)

           SET PSGLFD=$PIECE(UD2,U,4)

 +10       IF ('PSJMPRN&(QST="P"))

               QUIT

 +11       SET PSJSI=$SELECT($PIECE(UD0,U,22):"*** NOT TO BE GIVEN ***",1:$PIECE($GET(^PS(55,PSGP,5,ON,6)),U))

 +12       SET PSJHOLD=$SELECT($PIECE(UD0,U,9)["H":1,1:0)

 +13       IF QST'="P"

               DO ADMIN

 +14       IF QST="P"

               SET PSJATME=9999

               SET PSJADT=9999999

               DO @PSGSS

 +15       QUIT

 +16      ;

ADMIN     ;

 +1        SET PSGPLO=ON

           SET PSGMFOR=""

           DO ^PSJPL0

 +2        IF PSJPLC=1

               SET PSJATME=8888

               SET PSJADT=8888888

               DO @PSGSS

 +3        FOR ADMIN=0:0

               SET ADMIN=$ORDER(PSGMAR(ADMIN))

               IF 'ADMIN

                   QUIT

               SET PSJADT=$PIECE(ADMIN,".")

               SET PSJATME=+$EXTRACT($PIECE(ADMIN,".",2)_"0000",1,4)

               DO @PSGSS

 +4        QUIT

 +5       ;

P         ;*** Set up ^TMP for sort by patients

 +1        NEW QST

           SET QST=$SELECT("CO"[PST:PST,PST="OC":"OA",1:"CR")

 +2        SET ^TMP($JOB,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB

 +3        SET ^TMP($JOB,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD

 +4        SET ^TMP($JOB,QST,PSGP,ON,1)=PSJSI

 +5        QUIT

 +6       ;

G         ;*** Goto W to set up ^TMP when print by WARD/WARD GROUP

 +1       ;

W         ;*** Set up ^TMP when listing by ward

 +1        IF PSGRBADM="A"

               SET ^TMP($JOB,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 +2        IF PSGRBADM="R"

               SET ^TMP($JOB,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 +3        IF PSGRBADM="P"

               SET ^TMP($JOB,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB

 +4        SET ^TMP($JOB,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD

 +5        SET ^TMP($JOB,QST,PSGP,ON,1)=PSJSI

 +6        QUIT

PSJMEDS.m