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

PSJPDV1.m

Go to the documentation of this file.
  1. PSJPDV1 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ;15 May 98 / 9:28 AM
  1. ;;5.0;INPATIENT MEDICATIONS;**3,33,58,267**;16 DEC 97;Build 158
  1. ;
  1. ; Reference to ^PS(55 supported by DBIA #2191.
  1. ;
  1. S PG=1,(PREVNM,TMPNM)="",(PREVWD,TMPWD)="",WFLG=0
  1. REC ;write patient and order information
  1. D HEADING G:$D(QFLG) DONE
  1. I '$D(^TMP("PSJ",$J)) W !!,"NO DATA FOUND" G DONE
  1. S FST="" F S FST=$O(^TMP("PSJ",$J,FST)) Q:FST=""!($D(QFLG)) S SND="" F S SND=$O(^TMP("PSJ",$J,FST,SND)) Q:SND=""!($D(QFLG)) S ORD="" F S ORD=$O(^TMP("PSJ",$J,FST,SND,ORD)) Q:'ORD!($D(QFLG)) D
  1. .; naked ref below refers to line above
  1. .S ND=^(ORD),PER=$S(PSJSRT="P":FST,1:SND),STD=$S(PSJSRT="P":SND,1:FST)
  1. .S WFLG=0,(NM,TMPNM)=$P(PER,";"),(WARD,TMPWD)=$P(ND,"^",2) I PSJSRT="P" S:(TMPNM=PREVNM)&(TMPWD=PREVWD) NM="",WFLG=1 I TMPNM'=PREVNM S PREVNM=NM W !
  1. .S:TMPWD'=PREVWD PREVWD=WARD S (PSGP,IEN)=$P(PER,";",2),PSJJORD=+ORD D:ORD["V" IVREC Q:$D(QFLG) D:ORD'["V" UDREC Q:$D(QFLG)
  1. ;
  1. DONE K ADCNT,CONT,FST,JJ,LCNT,LN,ND3,ND3FLG,ND4,ON,OPI,ORD,P,PER,PG,PREVNM,PEVWD,PRIMD,PSJAD,PSJSOL,RSTFLG,SI,SND,SOLCNT,SSN,TMPNM,TMPWD,WCNT,WFLG,WRD,WARD,RMBD,PSJ,DRGI,DRGN,DRGT
  1. Q
  1. ;
  1. UDREC ;write Unit Dose record
  1. N X,PSJ K ND3FLG
  1. D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",30,30,.PSJ,0)
  1. S RSTFLG=2,SSN=$P(ND,U),WARD=$P(ND,U,2),RMBD=$P(ND,U,3)
  1. D:$Y+5>IOSL HEADING Q:$D(QFLG)
  1. W !!,NM,?32,PSJ(1),?68,$E($$ENDTC^PSGMI(STD),1,5),?75,$E($$ENDTC^PSGMI($P(ND,U,6)),1,5),! W:'WFLG SSN
  1. N X F X=1:0 S X=$O(PSJ(X)) Q:'X W ?32,PSJ(X) D THEREST I RSTFLG>3&($X>32) W !
  1. N I S WCNT=1,SI=$P($G(^PS(55,PSGP,5,PSJJORD,6)),"^") I $TR(SI," ")]"" W:$X>31 ! F I=1:1:$L(SI," ") S WRD=$P(SI," ",I) Q:(I>1)&$P(SI," ",I-1,180)="" S WCNT=WCNT+1 D
  1. .I $X+$L(WRD)>79 W ! I 'WFLG&('$D(ND3FLG)) W $P(ND,"^",3) S ND3FLG=1
  1. .W ?31," ",WRD
  1. I 'WFLG&('$D(ND3FLG)) W !,$P(ND,"^",3)
  1. K ND3FLG
  1. Q
  1. IVREC ;write IV record
  1. D:$Y+5>IOSL HEADING Q:$D(QFLG)
  1. N DRG,P,PSG,ON55,PSJ
  1. S RSTFLG=1,SSN=$P(ND,U),WARD=$P(ND,U,2),RMBD=$P(ND,U,3)
  1. S DFN=PSGP,ON=PSJJORD D GT55^PSIVORFB
  1. W !!,NM
  1. N X F X=0:0 S X=$O(DRG("AD",X)) Q:'X D NAME^PSIVUTL(DRG("AD",X),30,.PSJ,1) F JJ=0:0 S JJ=$O(PSJ(JJ)) Q:'JJ W ?32,PSJ(JJ) D THEREST I RSTFLG>3&($X>32) W !
  1. N X,PSJ F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),30,.PSJ,0) N JJ F JJ=0:0 S JJ=$O(PSJ(JJ)) Q:'JJ W:JJ=1 ?33,"in " W ?36,PSJ(JJ) D THEREST I RSTFLG>3&($X>31) W !
  1. W ?32,$P(P("MR"),U,2)_" "_P(9)_" "_P(8) D THEREST
  1. S OPI=$P(P("OPI"),"^") I OPI]"" W:$X>31 ! F X=1:1:$L(OPI," ") S Y=$P(OPI," ",X) D THEREST W:$X+$L(Y)>80 ! W ?32,Y," "
  1. F Q:RSTFLG>3 D THEREST
  1. Q
  1. THEREST ;
  1. I RSTFLG=1 W ?68,$E($$ENDTC^PSGMI(STD),1,5),?75,$E($$ENDTC^PSGMI(P(3)),1,5),! W:'WFLG SSN
  1. I RSTFLG=2 W ! W:'WFLG WARD
  1. I RSTFLG=3 S ND3FLG=1 W ! W:'WFLG RMBD
  1. S RSTFLG=RSTFLG+1
  1. Q
  1. HEADING I $E(IOST)'="P" W !,"Press RETURN to continue ""^"" to exit: " R CONT:DTIME S:CONT["^" QFLG=1 Q:$D(QFLG)
  1. W:$Y @IOF
  1. S NM=TMPNM,WFLG=0
  1. W !,$E($$ENDTC^PSGMI(DT),1,8),?70,"PAGE: ",PG S PG=PG+1
  1. S LN="LISTING OF PATIENTS WITH ORDERS CONTAINING "_$S(PSJSL="V":"VA CLASS(ES) OF DRUGS",PSJSL="O":"ORDERABLE ITEM(S)",PSJSL="D":"DISPENSE DRUG(S)")_":"
  1. W !! D LINE W !
  1. S LN="" F S LN=$O(PSJSNM(LN)) Q:LN="" W ! D LINE
  1. S LN="FROM "_$$ENDTC^PSGMI(PSJREPS)_" TO "_$$ENDTC^PSGMI(PSJREPF) W !! D LINE W !!
  1. F X=1:1:80 W "-"
  1. W !?68,"Start",?75,"Stop",!,"Patient",?32,"Order",?68,"Date",?75,"Date",!
  1. F X=1:1:80 W "-"
  1. Q
  1. LINE ;
  1. W ?(80-$L(LN))/2,LN Q