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

PSOUTLA.m

Go to the documentation of this file.
  1. PSOUTLA ;BHAM ISC/AMC - pharmacy utility program ;07/24/96 1:13 pm
  1. ;;7.0;OUTPATIENT PHARMACY;**1,15,23,56,126,222,354,444,496,526**;DEC 1997;Build 3
  1. ;External reference ^PS(54 supported by DBIA 2227
  1. ;External reference ^PSDRUG( supported by DBIA 221
  1. CHK I '$D(PY(PSPR)) W !?10,$C(7)," # ",PSPR," is not a valid choice." S PSPOP=1 Q
  1. I $D(PSDUP(PY(PSPR))) W !?10,$C(7),"RX# ",$P(^PSRX(+$P(PY(PSPR),"^"),0),"^")," is a duplicate choice." S PSPOP=1 Q
  1. S PSDUP(PY(PSPR))="" Q:'PSODIV Q:'$P(^PSRX(+PY(PSPR),2),"^",9) Q:+$P(^(2),"^",9)=PSOSITE
  1. S PSPRXN=+$P(PY(PSPR),"^")
  1. CHK1 I '$P(PSOSYS,"^",2) W !!,$C(7),"RX# "_$P(^PSRX(PSPRXN,0),"^")_" is not a valid choice. (Different Division)",! S PSPOP=1 Q
  1. I $P(PSOSYS,"^",3) K DIR,DUOUT,DTOUT D
  1. .W $C(7) S DIR("A",1)="",DIR("A",2)="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is from another division.",DIR("A")="Continue: (Y/N)",DIR(0)="Y",DIR("?",1)="'Y' FOR YES",DIR("?")="'N' FOR NO"
  1. .S DIR("B")="N" D ^DIR I 'Y!($D(DUOUT))!($D(DTOUT)) S PSPOP=1 W !
  1. K DIR,DUOUT,DTOUT Q
  1. ;
  1. ZIPIN ; input transform for ZIP field in file #59 internal format (no '-'s)
  1. ; Input: X as user entered value
  1. ; Output: X as internal value of user input OR
  1. ; undefined if input from user was invalid
  1. N % I X'?.N F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,20),%=%-1
  1. I X'?5N,(X'?9N) K X
  1. Q
  1. ;
  1. ZIPOUT ; output transform for ZIP - prints either ZIP or ZIP+4 (in 12345-1234)
  1. ; format.
  1. ; Input: Y internal value
  1. ; Output: Y external (12345 or 12345-1234)
  1. S Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:"")
  1. Q
  1. YN ;YES/NO PROMPT
  1. W !?5,"'Y' FOR YES",!?5,"'N' FOR NO",!
  1. Q
  1. DAYS ;
  1. K PSFMAX S ED=1,PSODEA=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3),PSDAYS=$P(^PSRX(DA,0),"^",8),CS=0
  1. D EDNEW K:ED PSFMAX,ED K:$P(^PSRX(DA,0),"^",9)'>MAX PSMAX
  1. Q
  1. EDNEW ;
  1. K PSMAX,PSFMAX
  1. ; Retrieving the Maximum Number of Refills allowed
  1. S PSMAX=$$MAXNUMRF^PSOUTIL(+$P(^PSRX(DA,0),"^",6),PSDAYS,+$P(^PSRX(DA,0),"^",3),.CLOZPAT)
  1. ;
  1. I PSRF>PSMAX D
  1. .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_PSMAX_".",!
  1. K PSTMAX D EDSTAT
  1. Q
  1. STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
  1. EDSTAT I PSRF>PTRF D EN^DDIOL(PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.","","$C(7),!") D EN^DDIOL(" ","","!")
  1. Q
  1. PARKILL S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA(1),"A",SUB)) Q:'SUB S CNT=SUB
  1. I '$G(RESK) D G:$D(DIRUT) PARKILL
  1. .D EN^DDIOL(" ","","!") K DIR S DIR(0)="FO^10:75",DIR("A",1)="Enter Reason for Edit:",DIR("A")="=>",DIR("?",1)="This is a required response. No Up-arrowing allowed."
  1. .S DIR("?")="Response must be 10-75 characters in length.",DIR("B")="Entered In Error"
  1. .D ^DIR I $D(DIRUT) D EN^DDIOL("This is a required response. No Up-arrowing allowed.","","!") Q
  1. .S ACOM=$S($G(Y)]""&('$D(DIRUT)):Y,1:"Partial Entered In Error.")
  1. .S PSOPRZ=$G(PSOPRZ)-1 S:PSOPRZ<0 PSOPRZ=0
  1. S:$G(RESK) ACOM="Partial fill returned to stock."
  1. D NOW^%DTC S CNT=CNT+1 S ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT,^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^6^"_ACOM K CNT,SUB,DIR,DTOUT,DUOUT
  1. Q
  1. SETUP ;enter/edit clinic sort groups
  1. W ! S (DLAYGO,DIC,DIE)=59.8,DIC("A")="Select Clinic Sort Group: ",DIC(0)="AEQML" D ^DIC G:"^"[$E(X) SETUPX G:Y<1 SETUP S DA=+Y,DR=".01;1" D ^DIE
  1. SETUPX K DIE,DIC,DA,DLAYGO,Y,X,DR
  1. Q
  1. FSIG(PSOFILE,PSOINTR,PSOLENTH) ;Format front door sig
  1. ;PSOFILE is 'P' if in Pending File, 'R' if in Prescription File
  1. ;PSOINTR is internal number for either file
  1. ;PSOLENTH is length of each line of the Sig
  1. ;returned in the FSIG array
  1. K FSIG I $G(PSOFILE)=""!('$G(PSOINTR))!('$G(PSOLENTH)) G FQUIT
  1. I PSOFILE'="P",PSOFILE'="R" G FQUIT
  1. I PSOFILE="P",'$D(^PS(52.41,+PSOINTR,0)) G FQUIT
  1. I PSOFILE="R",'$D(^PSRX(+PSOINTR,0)) G FQUIT
  1. I PSOFILE="R",'$P($G(^PSRX(+PSOINTR,"SIG")),"^",2) G FQUIT
  1. N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
  1. I PSOFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSOINTR,"SIG",NNN)) Q:'NNN S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
  1. I PSOFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
  1. ;S HSIG(1)=$P($G(^PSRX(PSOINTR,"SIG")),"^") S FFF=2 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN I $G(^(NNN,0))'="" S HSIG(FFF)=$G(^(0)),FFF=FFF+1
  1. S FFF=1 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN I $G(^(NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
  1. G:'$O(HSIG(0)) FQUIT
  1. FSTART S (FVAR,FVAR1)="",II=1
  1. F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D I $L(FVAR)>PSOLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
  1. .S FVAR1=$P(HSIG(FFF)," ",(CNT))
  1. .S FLIM=FVAR
  1. .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
  1. I $G(FVAR)'="" S FSIG(II)=FVAR
  1. I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
  1. FQUIT Q
  1. DRUGW ;
  1. F Z0=1:1 Q:$P(X,",",Z0,99)="" S Z1=$P(X,",",Z0) W:$D(^PS(54,Z1,0)) ?35,$P(^(0),"^"),! I '$D(^(0)) W ?35,"NO SUCH WARNING LABEL" K X Q
  1. Q
  1. HLNEW ;formats provider instructions in FSIG for front door order
  1. K FSIG N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,LLP,PSOLENTH
  1. S PSOLENTH=59,LLP=1 F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL S HSIG(LLP)=$G(WPARRAY(7,LLL)),LLP=LLP+1
  1. D FSTART Q
  1. HLNEWX ;
  1. K FSIG N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,LLP,PSOLENTH
  1. S PSOLENTH=59,LLP=1 F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL S HSIG(LLP)=$G(WPARRAY(6,LLL)),LLP=LLP+1
  1. D FSTART Q
  1. ;
  1. SUSFDS ;
  1. N SUSIEN
  1. Q:$O(^PSRX(DA,1,0))
  1. S SUSIEN=+$O(^PS(52.5,"B",DA,0)) Q:'$G(SUSIEN)
  1. Q:'$D(^PS(52.5,SUSIEN,0))!($G(^PS(52.5,SUSIEN,"P")))
  1. I '$P($G(^PS(52.5,SUSIEN,0)),"^",5),'$P($G(^(0)),"^",13) S $P(^PS(52.5,SUSIEN,0),"^",2)=X,^PS(52.5,"C",X,SUSIEN)="" D
  1. .I $P($G(^PS(52.5,SUSIEN,0)),"^",7)="Q" S ^PS(52.5,"AQ",X,+$P($G(^PS(52.5,SUSIEN,0)),"^",3),SUSIEN)="" D SCMPX^PSOCMOP(SUSIEN,"Q") Q
  1. .S ^PS(52.5,"AC",+$P($G(^PS(52.5,SUSIEN,0)),"^",3),X,SUSIEN)=""
  1. Q
  1. SUSFDK ;
  1. N SUSIEN
  1. Q:$O(^PSRX(DA,1,0))
  1. S SUSIEN=+$O(^PS(52.5,"B",DA,0)) Q:'$G(SUSIEN)
  1. Q:'$D(^PS(52.5,SUSIEN,0))!($G(^PS(52.5,SUSIEN,"P")))
  1. I '$P($G(^PS(52.5,SUSIEN,0)),"^",5),'$P($G(^(0)),"^",13) K ^PS(52.5,"C",X,SUSIEN) D
  1. .I $P($G(^PS(52.5,SUSIEN,0)),"^",7)="Q" K ^PS(52.5,"AQ",X,+$P($G(^PS(52.5,SUSIEN,0)),"^",3),SUSIEN) D KCMPX^PSOCMOP(SUSIEN,"Q") Q
  1. .K ^PS(52.5,"AC",+$P($G(^PS(52.5,SUSIEN,0)),"^",3),X,SUSIEN)
  1. Q
  1. ADD ;enter/edit automated devices - OPAI
  1. W ! S (DLAYGO,DIC,DIE)=52.53,DIC("A")="Select ADD Name: ",DIC(0)="AEQML" D ^DIC G:"^"[$E(X) ADDX G:Y<1 ADD S DA=+Y,DR=".01;1;2;3" D ^DIE G ADD
  1. ADDX K DIE,DIC,DA,Y,X,DR
  1. Q
  1. ;
  1. FLDTINTR(FILLTYPE) ; Input Transform for FILL DATE, REFILL DATE and PARTIAL DATE fields in the PRESCRIPTION file (#52)
  1. ;Input Parameter: FILLTYPE - Prescription Fill Type: "O": Original, "R": Refill, "P": Partial
  1. ;Input Variables: X - Fill Date entered / DA/DA(1) - Pointer to the PRESCRIPTION file (#52)
  1. N RXIEN,%DT,Y
  1. I '$D(X) Q
  1. S RXIEN=+$S(FILLTYPE="O":$G(DA),1:$G(DA(1)))
  1. S %DT="EX" D ^%DT S X=Y I Y<1 D EN^DDIOL("INVALID DATE","","$C(7),!!?5") K X Q ;*526
  1. I '$D(^PSRX(RXIEN,0)) Q
  1. I $P(^PSRX(RXIEN,0),U,13),X<$P(^PSRX(RXIEN,0),U,13) D K X Q
  1. . D EN^DDIOL($S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be before ISSUE DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,0),U,13),"2Z")_")","","$C(7),!!?5")
  1. I '$D(^PSRX(RXIEN,2)) Q
  1. I $P(^PSRX(RXIEN,2),U,6),X>$P(^PSRX(RXIEN,2),U,6) D K X Q
  1. . D EN^DDIOL($S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be after EXPIRATION DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,2),U,6),"2Z")_")","","$C(7),!!?5")
  1. Q
  1. ;
  1. FLDTHELP(FILLTYPE) ; Executable Help for FILL DATE, REFILL DATE and PARTIAL DATE fields in the PRESCRIPTION file (#52)
  1. ;Input Parameter: FILLTYPE - Prescription Fill Type: "O": Original, "R": Refill, "P": Partial
  1. ;Input Variables: DA/DA(1) - Pointer to the PRESCRIPTION file (#52)
  1. N RXIEN
  1. S RXIEN=+$S(FILLTYPE="O":$G(DA),1:$G(DA(1)))
  1. I $P($G(^PSRX(RXIEN,0)),"^",13) D
  1. . D EN^DDIOL("The "_$S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be before ISSUE DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,0),U,13),"2Z")_")","","!")
  1. I $P($G(^PSRX(RXIEN,2)),"^",6) D
  1. . D EN^DDIOL("The "_$S(FILLTYPE="O":"FILL",FILLTYPE="R":"REFILL",1:"PARTIAL")_" DATE cannot be after EXPIRATION DATE ("_$$FMTE^XLFDT($P(^PSRX(RXIEN,2),U,6),"2Z")_")","","!")
  1. Q