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

APSPCP1.m

Go to the documentation of this file. 
  1. APSPCP1 ; IHS/DSD/ENM/CIA/PLS - CHRONIC MED PROFILE ;07-Jan-2013 15:53;PLS
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;**2,1002,1013,1015**;09/03/97;Build 62
  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 'APSP CHRONIC MED PROFILE' Option
  1.  ;
  1.  ;INPUT VARIABLES- DFN
  1.  ;OUTPUT VARIABLES- DA,DFN,DOB,DT,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,SIG
  1.  ;TMP("PSOZCP"),X,X1,X2,PSOZCP("PAGE"),^TMP("PSOZCP",$J,DFN)
  1.  ;%ZIS,DIC,DIC(0)
  1.  ;
  1.  ;EXTERNAL CALLS- C^%DTC,^%ZIS,^DIC,^%ZTLOAD,^TMP("PSOZCP",$J)
  1.  ; Modified - IHS/CIA/PLS - 12/27/04 - Line BUILD+7
  1.  ;            IHS/MSC/PLS - 11/10/11 - TallMan support
  1.  ;                        - 01/07/13 - Fix for I variable conflict with FileMan
  1.  K DFN S DFN="",APSPCNT=0
  1.  S APSP("XSTAT")=""
  1.  D FMTO I $D(PSOZCP("FLG")) G EXIT1
  1.  S APSPASS=1
  1.  S PSOZCP="" F  S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC Q:Y<0  S DFN=+Y,APSPCNT=APSPCNT+1 S:$D(^PS(55,DFN,"P","CP")) APSP1(DFN)="",ZTSAVE("APSP1(")="" W:'$D(^PS(55,DFN,"P","CP")) !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS"
  1.  G:APSPCNT'>0 EXIT1
  1.  ;
  1. INIT ;ENTRY POINT IF DFN ALREADY DEFINED
  1.  D COPIES ; Asks number of copies
  1.  D:$G(APSPASS)'=1 FMTO ;IHS/DSD/ENM 02/05/99 ASK FOR NUMBER OF DAYS
  1.  I $D(PSOZCP("FLG")) G EXIT1
  1.  S:'$D(APSP1(DFN)) APSP1(DFN)=""
  1.  S %ZIS="QM"
  1.  S %ZIS("A")="Please enter PROFILE device: " D ^%ZIS
  1.  I POP G 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^APSPCP1",ZTIO=ION
  1.  S ZTSAVE("PSOZCP(""COPIES"")")="",ZTSAVE("%APSITE")="",ZTSAVE("PSOSITE")="" ;IHS/DSD/ENM 09/02/96 %APSITE,PSOSITE SAVED
  1.  S ZTSAVE("APSPBD")="",ZTSAVE("APSPED")="",ZTSAVE("APSP(""XSTAT"")")="" ;IHS/DSD/ENM 02/05/99
  1.  S ZTDESC="CHRONIC MEDICATION PROFILE"
  1.  D ^%ZTLOAD
  1.  G EXIT
  1.  ;
  1. FMTO ;EP
  1.  ;-------------------------------------------------------------------
  1.  ;IHS/DSD/ENM 02/08/99 CHRONIC MED DATE SET
  1.  ;IHS/DSD/LWJ 09/10/99 V6.0,patch 2  - if the user enters the program
  1.  ; from other than the main pharmacy menu we need to prompt for the div,
  1.  ; days for report..nxt line of code added
  1.  I '$D(PSOPAR) D ^PSOLSET S PSOZCP("DAYS")=$G(PSOZZCP("DAYS")) I PSOZCP("DAYS")'="" G CMEDXA  ;/IHS/DSD/LWJ 09/10/99
  1.  S PSOZCP("DAYS")=""
  1.  K PSOZP("FLG"),DIRUT,DTOUT
  1.  S DIR(0)="NO^1:999:0"
  1.  S DIR("B")=90,DIR("A")="Number of Days For Chronic Med Profile"
  1.  D ^DIR
  1.  I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G CMEDX
  1.  S PSOZCP("DAYS")=$S(+Y>0:+Y,1:90)
  1. CMEDXA S X1=DT,X2=-PSOZCP("DAYS") D C^%DTC S APSPBD=X-1_".2359",APSPED=DT_".2359"   ;IHS/DSD/LWJ 9/10/99 label added to line
  1. CMEDX Q
  1.  ;---------------------------------------------------------------------
  1. EN ;
  1.  I $G(PSOSITE)]"" S APSPZITE=$P(^PS(59,PSOSITE,0),"^")
  1.  F PSOZCP("I")=1:1:PSOZCP("COPIES") 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.  K ^TMP("PSOZCP",$J)
  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(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1. GETMP ;CREATE TMP DATA
  1.  S APSPTDFN=0
  1.  F  S APSPTDFN=$O(APSP1(APSPTDFN)) Q:'APSPTDFN  S ^TMP("PSOZCP",$J,APSPTDFN)=""
  1.  Q
  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"),%ZIS,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/05/99
  1.  K APSP1,AGE,APSPCNT,APSPZITE
  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.  N DRUGN
  1.  I (('$D(^PSRX(J,0)))&('$D(^PSRX(J,3)))) K ^PS(55,DA,"P","CP",J) G ENDBLD
  1.  I $D(^PSRX(J,0)),$D(^PSRX(J,3)) S APSP("LAST FILL")=$P(^PSRX(J,3),"^",1)
  1.  Q:APSP("LAST FILL")<APSPBD!(APSP("LAST FILL")>APSPED)
  1.  ; IHS/CIA/PLS - 12/27/04 - Status field was moved
  1.  ;I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15)
  1.  I $D(^PSRX(J,0)) S APSP("XSTAT")=$G(^PSRX(J,"STA"))
  1.  Q:APSP("XSTAT")=13  ; DELETED STATUS CHECK
  1.  Q:APSP("XSTAT")=12  ; CANCELLED STATUS CHECK
  1.  ;IHS/MSC/PLS - 11/10/11 - P1013
  1.  ;I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0)
  1.  I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),U,6),0)) D
  1.  .S DRUGN=^PSDRUG(+$P(^PSRX(J,0),U,6),0)
  1.  .S TMP("PSOZCP",$$UP^XLFSTR(DRUGN))=J_U_^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 $E(IOST,1,2)'="P-",$Y+6>IOSL S DIR(0)="E" D ^DIR Q:X="^"!($D(DTOUT))  W @IOF
  1.  Q
  1. PRINT1 ;
  1.  N DATA
  1.  I $E(IOST,1,2)="P-",$Y+6>IOSL W @IOF D HEADER
  1.  I $E(IOST,1,2)="C-",$Y+6>IOSL W @IOF D HEADER
  1.  S DATA=TMP("PSOZCP",PSZNAME)
  1.  ;S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER
  1.  W !?60,"|     |     |     |"
  1.  ;W !,RXNZ
  1.  W !,$P(DATA,U,2)
  1.  ;W ?8,PSZNAME ;DRUG NAME AND STRENGTH
  1.  W ?8,$P(^PSDRUG($P(DATA,U,7),0),U) ;DRUG NAME AND STRENGTH
  1.  ;W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY
  1.  W ?42,$P(DATA,U,8) ;QUANTITY
  1.  ;S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE
  1.  S LRXD=+^PSRX($P(DATA,U),3)
  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.  ;
  1.  ;W !,?10,$P(TMP("PSOZCP",PSZNAME),"^",11) ;SIG
  1.  S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) D:X]"" ^APSPCP
  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) ;IHS/DSD/ENM 05/24/96 $O ADDED
  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: ",$G(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.  D GMR ;GET ALLERGY DATA
  1.  W !!,"RX#      DRUG",?42,"QTY",?50,"LAST FILLED",!!
  1.  Q
  1.  ;
  1. COPIES ;
  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 K 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.  ;GET ALLERGY INFORMATION
  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