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

PSJCOM1.m

Go to the documentation of this file. 
  1. PSJCOM1 ;BIR/CML3-DISPLAY COMPLEX ORDERS FOR DISCONTINUE ;02 Feb 2001  12:20 PM
  1.  ;;5.0; INPATIENT MEDICATIONS ;**110,127**;16 DEC 97
  1.  ;
  1.  ; Reference to ^VALM1 is supported by DBIA 10116.
  1.  ; Reference to ^PS(55 is supported by DBIA 2191.
  1.  ; Reference to ^%DTC is supported by DBIA 10000.
  1.  ; Reference to ^PS(51.2 is supported by DBIA 2178.
  1.  ; Reference to ^DIE is supported by DBIA 10018.
  1.  ; Reference to ^DIR is supported by DBIA 10026.
  1.  ;
  1. CMPLX(PSGP,ON,PSGORD) ;
  1.  D PAUSE K PSJCM
  1.  N PSJLINE,PSX,PSCM
  1.  S PSJLINE=1
  1.  I PSGORD["P" N PSJO S PSJO=0 F  S PSJO=$O(^PS(53.1,"ACX",ON,PSJO)) Q:'PSJO  D
  1.  .Q:PSJO=+PSGORD  S PSJOO=PSGORD D DSPLORDU(PSGP,PSJO_"P") S PSJCM(PSJO_"P",PSJLINE)="",PSJLINE=PSJLINE+1
  1.  I PSGORD'["P" N PSJO,PSJOO S PSJOO="",PSJO=0 F  S PSJO=$O(^PS(55,"ACX",ON,PSJO)) Q:'PSJO  F  S PSJOO=$O(^PS(55,"ACX",ON,PSJO,PSJOO)) Q:PSJOO=""  D
  1.  .Q:PSJOO=PSGORD  D:PSJOO["U" DSPLORDU(PSGP,PSJOO) D:PSJOO["V" DSPLORDV(PSGP,PSJOO) S PSJCM(PSJOO,PSJLINE)="",PSJLINE=PSJLINE+1
  1.  N ON S ON="" F  S ON=$O(PSJCM(ON)) Q:ON=""  D
  1.  .W ! F PSX=0:0 S PSX=$O(PSJCM(ON,PSX)) Q:'PSX  D
  1.  ..W !,PSJCM(ON,PSX) D:'(PSX#6) PAUSE
  1.  W !
  1.  Q
  1.  ;
  1. CMPLX2(PSGP,ON,PSGORD) ;
  1.  Q:$G(PSGORD)'["U"
  1.  N PSJLINE S PSJLINE=0
  1.  D FULL^VALM1
  1.  D DSPLORDU(PSGP,PSGORD)
  1.  W ! S PSJLINE="" F  S PSJLINE=$O(PSJCM(PSGORD,PSJLINE)) Q:PSJLINE=""  W !,PSJCM(PSGORD,PSJLINE) D:'((PSJLINE+1)#6) PAUSE
  1.  D EN^PSGPEN(PSGORD)
  1.  W !
  1.  Q
  1.  ;
  1. UPDATE ; Refresh array, actions, & display.
  1.  D GETUD^PSJLMGUD(DFN,ON),INIT^PSJLMUDE(DFN,ON) S VALMBCK="R"
  1.  Q
  1. HOLDHDR ; Freeze header text while processing order actions
  1.  I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
  1.  Q
  1.  ;
  1. DSPLORDU(PSGP,ON)   ; Display UD order for order check as in the Inpat Profile.
  1.  NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y K PSJCM
  1.  S F=$S(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",")
  1.  S NODE0=$G(@(F_"0)")),NODE2=$G(@(F_"2)"))
  1.  D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
  1.  I ON["P",$P(NODE0,U,4)="F" D DSPLORDV(PSGP,ON) Q
  1.  S SCH=$P(NODE0,U,7)
  1.  S STAT=$P(NODE0,U,9)
  1.  D NOW^%DTC I "A"[STAT I $P(NODE2,U,4)<% D EXPIRE S STAT="E"
  1.  I STAT="A",$P(NODE0,U,27)="R" S STAT="R"
  1.  I STAT'="P" S PSJID=$E($$ENDTC^PSGMI($P(NODE2,U,2)),1,5),SD=$E($$ENDTC^PSGMI($P(NODE2,U,4)),1,5)
  1.  I STAT="P" S (PSJID,SD)="*****",SCH="?"
  1.  F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX  D
  1.  . S:PSJX=1 X=SCH_"  "_PSJID_"  "_SD_"  "_$E(STAT,1)
  1.  . S:PSJX=1 DRUGNAME(1)=$$SETSTR^VALM1(X,$E(DRUGNAME(1),1,40),42,20)
  1.  . S PSJCM(ON,PSJLINE)="        "_DRUGNAME(PSJX)
  1.  . S PSJLINE=PSJLINE+1
  1.  Q
  1. DSPLORDV(DFN,ON)   ; Display IV order for order check as in the Inpat Profile.
  1.  N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y
  1.  S TYP="?" I ON["V" D
  1.  .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
  1.  .D NOW^%DTC I "A"[P(17) I P(3)<% D EXPIRE S P(17)="E"
  1.  .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
  1.  .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
  1.  S PSJCT=0,PSJL=""
  1.  I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4))
  1.  S PSJIVFLG=1 D PIVAD,SOL
  1.  Q
  1. SOL ;
  1.  S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_"        in"
  1.  S DRG=0 F  S DRG=+$O(DRG("SOL",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F  S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL="      "
  1.  Q
  1. PIVAD ; Print IV Additives.
  1.  F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP
  1.  Q
  1.  ;
  1. PIV1 ; Print Sched type, start/stop dates, and status.
  1.  K PSJIVFLG
  1.  F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
  1.  I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
  1.  E  S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
  1.  Q
  1. SETTMP ;
  1.  S PSJCM(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1
  1.  Q
  1. PAUSE ;
  1.  K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
  1.  Q
  1. NEW ;
  1.  Q:'PSJCOM
  1.  Q:PSGORD'["P"
  1.  M ^TMP("PSJCOM",$J,+PSGORD)=^PS(53.1,+PSGORD)
  1.  S PSGS0Y=PSGAT,PSGNESD=PSGSD,PSGNEFD=PSGFD,PSGOEPR=PSGPR,PSGPDRG=PSGPD,PSGPDRGN=PSGPDN,PSGOEE="E"
  1.  S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",27)="E",$P(^(0),"^",9)="DE"
  1.  W:'$D(PSGOEE)&'$D(PSGOES) !!,"...transcribing this ",$S($D(PSGOES):"",'PSGOEAV:"non-verified ",1:"active "),"order..." S PSGOETOF=1 S:PSGSM="" PSGSM=0
  1.  ;I PSGPR'=PSGOEPR D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),U,2)=PSGPR,PSGOEPR=PSGPR
  1.  K ND4,DA D NOW^%DTC S PSGDT=+$E(%,1,12),DA=+PSGORD
  1.  S PSJOWALL=+$G(^PS(55,PSGP,5.1))
  1.  I $D(^PS(51.2,+PSGMR,0)),$P(^(0),U,3)]"" S PSGMRN=$P(^(0),U,3)
  1.  I PSGS0XT="D",'PSGS0Y S PSGS0Y=$E(PSGNESD_"00011",9,12)
  1.  S ND=DA_U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_$S(PSGOEAV:"A",1:"N")_"^^^^^"_PSGDT_U_PSGP_U_PSGDT S:PSGNEDFD $P(ND,U,$P(PSGNEDFD,U)["L"+10)=+PSGNEDFD
  1.  S:$D(PSGOEE) $P(ND,U,24,25)=PSGOEE_U_PSGORD S:'PSGOEAV $P(ND,U,18)=DA S ND2=PSGSCH_U_$S(+PSGNESD=PSGNESD:+PSGNESD,1:"")_"^^"_+PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+PSJPWD
  1.  ;I PSGOEAV S F=^PS(55,PSGP,0) I $P(F,"^",7)="" S $P(F,"^",7)=$P($P(ND,"^",16),"."),$P(F,"^",8)="A",^(0)=F
  1.  S $P(ND4,U,7)=DUZ I PSGOEAV,PSJSYSU D
  1.  .S $P(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_PSGDT,$P(ND4,U,+PSJSYSU=1+9)=1,$P(ND4,U,+PSJSYSU=3+9)=0
  1.  .S $P(ND4,U,9,10)=+$P(ND4,U,9)_U_+$P(ND4,U,10)
  1.  S F="^TMP(""PSJCOM2"","_$J_","_DA_",",@(F_"0)")=ND
  1.  ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
  1.  S @(F_".2)")=PSGPDRG_U_PSGDO_U_PSJNOO S:$G(PSJDOSE("DO"))]"" $P(^(.2),U,5,6)=$P(PSJDOSE("DO"),U,1,2) S:PSJCOM]"" $P(^(.2),"^",8)=PSJCOM
  1.  I '$D(PSJDOSE("DO")),$D(PSGORD) S $P(@(F_".2)"),U,5,6)=$P(@("^PS("_$S(PSGORD["U":"55,"_PSGP_",5",1:53.1)_","_+PSGORD_",.2)"),U,5,6)
  1.  ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
  1.  S @(F_"2)")=$P(ND2,"^",1,6),^(4)=ND4 S:PSGSI]"" ^(6)=PSGSI
  1.  ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
  1.  S (C,X)=0 F  S X=$O(^PS(53.45,PSJSYSP,2,X)) Q:'X  S D=$G(^(X,0)) I D,$S('$P(D,U,3):1,1:$P(D,U,3)>DT) S C=C+1,@(F_"1,"_C_",0)")=$P(D,U,1,2),@(F_"1,""B"","_+D_","_C_")")=""
  1.  S:C @(F_"1,0)")=U_$S(PSGOEAV:55.07,1:53.11)_"P^"_C_U_C
  1.  ; Naked references below refers to full reference in F which is ^TMP("PSJCOM2",$J,DA,
  1.  S (C,Q)=0 F  S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q  S X=$G(^(Q,0)) S:X]"" C=C+1,@(F_"3,"_C_",0)")=X
  1.  S:C @(F_"3,0)")=U_$S(PSGOEAV:55.08,1:53.12)_U_C_U_C
  1.  S:C @(F_"12,0)")=U_$S(PSGOEAV:55.0612,1:53.1012)_U_C_U_C
  1.  W "."
  1. OUT ;
  1.  K PSGOETOF
  1. DONE ;
  1.  K C,D,ND,ND2,ND4,PSGDO,PSGDRG,PSGDRGN,PSGFOK,PSGHSM,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGPDRG,PSGPDRGN,PSGSI,PSGSTN,PSJDOSE
  1.  Q
  1. EXPIRE ;Change status of order to expired and send notice to OE/RR
  1.  N DA,DIE,DR,PSGPO,PSIVACT
  1.  Q:'$G(PSJOO)!($G(PSJOO)["P")
  1.  S STATUS="E",(PSGPO,PSIVACT)=1,DA=+PSJOO,DA(1)=PSGP,DIE=$S(PSJOO["V":"^PS(55,"_PSGP_",""IV"",",1:"^PS(55,"_PSGP_",5,"),DR=$S(PSJOO["V":"100////E",1:"28////E") D ^DIE
  1.  D EN1^PSJHL2(PSGP,"SC",PSJOO)
  1.  Q