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

APSPCP2.m

Go to the documentation of this file. 
  1. APSPCP2 ;IHS/OHPRD/JCM - CHRONIC MED PROFILE;27-Dec-2004 07:31;PLS
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;**1002**;09/03/97
  1.  ;THIS ROUTINE PRINTS A SUMMARY PROFILE OF ALL CURRENT CHRONIC
  1.  ;MEDICATIONS TO PUT IN THE PATIENT'S CHART
  1.  ;This routine is called by APSPNE4, APSPCP1 is called by option
  1.  ; Modified - IHS/CIA/PLS - 03/14-04
  1.  ;                          12/27/04 - Line BUILD+7
  1.  Q
  1.  ;
  1.  ;INPUT VARIABLES- DFN
  1.  ;
  1. INIT ;EP
  1.  ;NOTE: THIS EP IS CALLED BY CPCK^APSPNE4+1
  1.  S PSOZCP("COPIES")=$G(PSOZCP("COPIES",1))
  1.  S APSP("XSTAT")=""
  1.  D FMTO
  1.  G:$D(PSOZCP("FLG")) EXIT1
  1.  S:'$D(APSP1(DFN)) APSP1(DFN)=""
  1.  S %ZIS="QM"
  1.  S %ZIS("A")="Please enter PROFILE device: " D ^%ZIS
  1.  G:POP EXIT1
  1.  I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") D ^%ZISC G INIT
  1.  I IO=IO(0)!('$D(IO("Q"))) G EN
  1.  S ZTRTN="EN^APSPCP2",ZTIO=ION ;IHS/DSD/ENM 06/14/99
  1.  F G="PSOZCP(","APSPBD","APSPED","APSP(","APSP1(","PSOSITE" S ZTSAVE(G)="" ;IHS/DSD/LWJ 9/22/99 - changed APSP to be an open array reference, added PSOSITE and APSP1 open array
  1.  S ZTDESC="CHRONIC MEDICATION PROFILE"
  1.  D ^%ZTLOAD
  1. EXIT ;
  1.  D ^%ZISC
  1. EXIT1 K SIG,DA,DFN,DOB,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,TMP,DIC
  1.  K PSOZCP,X,POP,IO("Q"),ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTSK,Y
  1.  K ^TMP("PSOZCP",$J),DX,DY,APSPBD,APSPED,APSPASS,APSP("LAST FILL"),APSP("XSTAT"),APSPTDFN ;IHS/DSD/ENM 02/08/99
  1.  Q
  1.  ;
  1. FMTO ;EP
  1.  ; Get From/To date
  1.  S X1=DT,X2=-PSOZZCP("DAYS") D C^%DTC S APSPBD=X-1_".2359",APSPED=DT_".2359"
  1. CMEDX Q
  1. EMPRT ;EP CALLED BY CPCK^APSPNE4+2
  1.  ; NON-QUEUE PRINT MODULE
  1.  S:'$D(^TMP("PSOZCP",$J)) ^TMP("PSOZCP",$J,DFN)=""
  1.  D FMTO
  1.  I $G(APSPCPP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Enter Profile Device: " D ^%ZIS K %ZIS("A") G:POP EXIT S APSPCPP=ION
  1.  S IOP=APSPCPP D ^%ZIS G:POP EXIT
  1. EN ;
  1.  I $G(PSOSITE)]"" S APSPZITE=$P(^PS(59,PSOSITE,0),"^")
  1.  F PSOZCP("I")=1:1:$G(PSOZCP("COPIES"),1) D PATIENT
  1.  D EXIT
  1.  Q
  1.  ;
  1. PATIENT ;
  1.  S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY")
  1.  U IO
  1.  S DA=""
  1.  D GETMP K APSPTDFN
  1.  F I=0:0 S DA=$O(^TMP("PSOZCP",$J,DA)) Q:DA'=+DA  D START W:$E(IOST,1,2)="P-" @IOF
  1.  I PSOZCP("I")=PSOZCP("COPIES"),$D(ZTSK) K ZTSK,IO("Q")
  1.  Q
  1. GETMP ;CREATE TMP DATA - NEW MODULE 07/30/99
  1.  S APSPTDFN=0
  1.  F  S APSPTDFN=$O(APSP1(APSPTDFN)) Q:'APSPTDFN  S ^TMP("PSOZCP",$J,APSPTDFN)=""
  1.  Q
  1. START ;
  1.  K TMP("PSOZCP")
  1.  S PSOZCP("PAGE")=0
  1.  D HEADER
  1.  ;
  1.  ;PRESCRIPTION DFN NUMBER
  1.  S J=""
  1.  F I=0:0 S J=$O(^PS(55,DA,"P","CP",J)) Q:J'=+J  D BUILD
  1.  ;
  1.  ;START OF PRINTING
  1.  I $D(TMP("PSOZCP"))>0 D PRINT
  1.  Q
  1. BUILD ;
  1.  ;BUILDS PRESCRIPTION DATA
  1.  ;IHS/DSD/LWJ 9/21/99 - eliminate the cross reference if the
  1.  ;prescription no longer exists - added next line of code
  1.  I (('$D(^PSRX(J,0)))&('$D(^PSRX(J,3)))) K ^PS(55,DA,"P","CP",J) G ENDBLD   ;IHS/DSD/LWJ 9/21/99
  1.  I $D(^PSRX(J,0)),$D(^PSRX(J,3)) S APSP("LAST FILL")=$P(^PSRX(J,3),"^",1) ;IHS/DSD/ENM 02/08/99
  1.  Q:APSP("LAST FILL")<APSPBD!(APSP("LAST FILL")>APSPED)  ;IHS/DSD/ENM 02/08/99
  1.  ; Modified - IHS/CIA/PLS - 12/27/04 - Status field has moved
  1.  ;I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15) ;IHS/DSD/ENM 02/11/99
  1.  I $D(^PSRX(J,0)) S APSP("XSTAT")=$G(^PSRX(J,"STA"))
  1.  Q:APSP("XSTAT")=13  ;IHS/DSD/ENM 05/12/99 STATUS CHECK
  1.  Q:APSP("XSTAT")=12  ;IHS/DSD/ENM 06/14/99 STATUS CHECK
  1.  I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0)
  1.  ;
  1. ENDBLD Q
  1. PRINT ;
  1.  S PSZNAME=0
  1.  F I=0:0 S PSZNAME=$O(TMP("PSOZCP",PSZNAME)) Q:PSZNAME=""  D PRINT1 I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="FO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))  W @IOF
  1.  Q
  1. PRINT1 ;
  1.  I $E(IOST,1,2)="P-",$Y+6>IOSL W @IOF D HEADER
  1.  S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER
  1.  W !?60,"|     |     |     |"
  1.  W !,RXNZ
  1.  W ?8,PSZNAME ;DRUG NAME AND STRENGTH
  1.  W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY
  1.  S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE
  1.  W ?50,$E(LRXD,4,5),"-",$E(LRXD,6,7),"-",$E(LRXD,2,3),"  "
  1.  F I=1:1:3 W "|_____"
  1.  W "|"
  1.  S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) D:X]"" ^APSPSIG
  1.  W !,?10,SIG
  1.  I $D(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,0)) W !,"FILLED:  " D FILL ;CHECKS FOR REFILLS
  1.  Q
  1. FILL ;
  1.  S ISDZ=$P(TMP("PSOZCP",PSZNAME),"^",14) ;SETS ORIGINAL ISSUE DATE
  1.  W $E(ISDZ,4,5),"-",$E(ISDZ,6,7),"-",$E(ISDZ,2,3)
  1.  F RFZ=0:0 S RFZ=$O(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,RFZ)) Q:'RFZ  W " ",$E(^(RFZ,0),4,5),"-",$E(^(0),6,7),"-",$E(^(0),2,3)
  1.  Q
  1.  ;
  1.  S PSOZCP("PAGE")=PSOZCP("PAGE")+1
  1.  W !!!!,?27,"CHRONIC MEDICATION PROFILE"
  1.  W ?60,"DATE : ",$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3)
  1.  W !,?27,"SITE: ",APSPZITE ;IHS/DSD/ENM 09/06/96
  1.  W !!,$P(^DPT(DA,0),"^",1) ;PATIENTS NAME
  1.  W ?40,"CHART #  ",$P(^AUPNPAT(DA,41,DUZ(2),0),"^",2) ;CHART NO.
  1.  W ?70,"Page ",PSOZCP("PAGE")
  1.  S DOB=$S($L(+$P(^DPT(DA,0),"^",3)):+$P(^DPT(DA,0),"^",3),1:"") ;DATE OF BIRTH
  1.  W !,?40,"DOB:  ",$S(DOB:$E(DOB,4,5)_"-"_$E(DOB,6,7)_"-"_$E(DOB,2,3),1:"UNKNOWN")
  1.  ;GET ALLERGY DATA
  1.  D GMR
  1.  W !!,"RX#      DRUG",?42,"QTY",?50,"LAST FILLED",!!
  1.  Q
  1.  ;
  1. COPIES ;EP
  1.  K PSOZP("FLG"),DIRUT,DTOUT
  1.  S DIR(0)="NO^1:10:0"
  1.  S DIR("B")=1,DIR("A")="Number of Chronic Med Profile copies"
  1.  D ^DIR
  1.  I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G COPIESX
  1.  S PSOZCP("COPIES")=$S(+Y>0:+Y,1:1)
  1. COPIESX ;
  1.  Q
  1. GMR X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" I $T D:'$D(PSOPTPST) GMRA
  1. Q K SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS Q
  1. GMRA W !,"REACTIONS: " D ^GMRADPT S I1=0 F I=0:0 S I=$O(GMRAL(I)) Q:I'>0  W:I1 ", " S AL=$P(GMRAL(I),"^",2) W:$X+$L(AL)>75 !?5 W AL S I1=1
  1.  K GMRA,GMRAL Q