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

PSOSIG.m

Go to the documentation of this file.
  1. PSOSIG ;BIR/RTR-Utility to create SIG ;Feb 25, 2021@14:48
  1. ;;7.0;OUTPATIENT PHARMACY;**46,99,114,391,313,282,455,446,402,500,515,514,574,584,449**;DEC 1997;Build 2
  1. ;External reference to PS(51 supported by DBIA 2224
  1. ;External reference to PS(51.1 supported by DBIA 2225
  1. ;External reference to PSDRUG( supported by DBIA 221
  1. ;
  1. EN(PSOSIGX) ;
  1. N VARIABLE
  1. Q
  1. SCH ;*282 Preserve old functionality
  1. I $D(DTOUT)!($D(DUOUT)) Q
  1. I Y>0!($G(SCH)[" ") S SCHEX=$$SCHE(SCH)
  1. I Y'>0 W !,?2,"Free text '"_$G(SCH)_"' entered for schedule"
  1. Q
  1. ;
  1. ;SCHE is the new schedule expander
  1. SCHE(SCH) ;
  1. ;SCH = Schedule entered
  1. ;Returns Expanded Schedule, or ""
  1. N SCHEX,SPCT
  1. I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>$S(SCH["PRN":4,1:3))!($L(SCH)>20)!($L(SCH)<1) K SCH Q ""
  1. S SCH=$$UPPER(SCH)
  1. S SPCT=0 F I=1:1:$L(SCH) I $E(SCH,I)=" " S SPCT=SPCT+1
  1. S SCHEX=$$EXP(SCH) I SCHEX]"" Q SCHEX
  1. Q:SPCT=0 SCH
  1. Q $$SCHE($P(SCH," ",1,SPCT))_" "_$$SCHE($P(SCH," ",SPCT+1))
  1. EXP(X) ; expand based on 51.1 and 51
  1. N PSIN,SCFLG,SCHEX
  1. S PSIN=0 F S PSIN=$O(^PS(51.1,"APPSJ",X,PSIN)) Q:'PSIN!$G(SCFLG) I $P(^PS(51.1,PSIN,0),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SCFLG=1
  1. Q:$G(SCFLG) SCHEX
  1. S PSIN=0 F S PSIN=$O(^PS(51.1,"D",X,PSIN)) Q:'PSIN!$G(SCFLG) I $P(^PS(51.1,PSIN,0),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SCFLG=1
  1. Q:$G(SCFLG) SCHEX
  1. S PSIN=0 F S PSIN=$O(^PS(51,"B",X,PSIN)) Q:'PSIN!$G(SCLFL) I PSIN,($P(^PS(51,PSIN,0),"^",4)<2)&($P($G(^PS(51,"A",X)),"^")'="") S SCHEX=$P(^(X),"^"),SCFLG=1
  1. Q:$G(SCFLG) SCHEX
  1. S PSIN=0 F S PSIN=$O(^PS(51,"D",X,PSIN)) Q:'PSIN!$G(SCLFL) I PSIN,($P(^PS(51,PSIN,0),"^",4)<2)&($P($G(^PS(51,"A",X)),"^")'="") S SCHEX=$P(^(X),"^"),SCFLG=1
  1. Q:$G(SCFLG) SCHEX
  1. I X[" " Q ""
  1. ; expand DOW ;p449
  1. N DOW,VAL,VAL1,STR,I,Y,XX,YY,TM
  1. S DOW="SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",(STR,SCHEX)="",TM=$P(X,"@",2)
  1. F I=1:1:$L(X)+1 S VAL=$E(X,I) S:VAL?1AN STR=STR_VAL I VAL'?1AN D I VAL="@" Q
  1. .Q:STR=""
  1. .F J=1:1:7 S VAL1=$P(DOW,";",J),XX=0 I STR'="",(";"_VAL1)[(";"_STR) S YY=$P(SCHEX," ",$L(SCHEX," ")),SCHEX=$S(SCHEX="":"",DOW'[YY:SCHEX_" ",1:SCHEX_", ")_VAL1,STR="",XX=1 Q
  1. .I 'XX,SCHEX'="" S YY=$P(SCHEX," ",$L(SCHEX," ")),SCHEX=$S(SCHEX="":"",DOW'[YY:SCHEX_" ",1:SCHEX_" ")_STR,STR=""
  1. I SCHEX="" Q ""
  1. S XX=$L(SCHEX,", ") I XX>1 S STR=$P(SCHEX,", ",1,XX-1)_" AND "_$P(SCHEX,", ",XX),SCHEX=STR
  1. I SCHEX=X Q ""
  1. Q SCHEX_$S(TM'="":"@",1:"")_TM
  1. ;
  1. QTY(PSOQX) ; PSOQX - Array containing Rx information
  1. N QDOSE,PSORXIEN,PSODSEDT,PSOOUTQT
  1. K PSOQX("QTY")
  1. S PSORXIEN=$S($G(PSOQX("IRXN")):+PSOQX("IRXN"),1:0)
  1. S PSODSEDT=$S(PSORXIEN&$D(PSOQX(52,PSORXIEN,8)):1,'PSORXIEN&($G(PSOQX("FLD"))=8):1,1:0) ; DAYS SUPPLY field edited
  1. I 'PSORXIEN,$G(PSOQX("FLD"))=7 Q ; QTY field being edite for Pending Order (do not ajust current QTY)
  1. S PSOOUTQT=1
  1. QTYCP ;CPRS qty call comes through here
  1. N PSQQUIT,QTSH,PSQ,PSQMIN,PSQMINZ,PSOQRND,PSOLOWER,PSOLOWX,PSOLOWXL,PSOLOWST,PSORXDRG
  1. K PSOFRQ S PSQQUIT=0
  1. I '$G(PSOCPRQT) S QDOSE=0 F PSQ=0:0 S PSQ=$O(PSOQX("DOSE",PSQ)) Q:'PSQ S QDOSE=PSQ S:'$G(PSOQX("DOSE ORDERED",PSQ)) PSQQUIT=1
  1. I '$G(PSOCPRQT) Q:PSQQUIT
  1. Q:'$G(PSOQX("DAYS SUPPLY"))
  1. Q:'$G(QDOSE)
  1. G:QDOSE>1 COMP
  1. Q:'$G(PSOQX("DOSE ORDERED",1))
  1. Q:'$G(PSOQX("DAYS SUPPLY"))&('$G(PSOQX("DURATION",1)))
  1. S PSOLOWER=0
  1. I $G(PSOQX("DURATION",1)) D
  1. .S PSOLOWX=$L(PSOQX("DURATION",1))
  1. .S PSOLOWXL=$S($E(PSOQX("DURATION",1),PSOLOWX)="M":1,$E(PSOQX("DURATION",1),PSOLOWX)="H":60,$E(PSOQX("DURATION",1),PSOLOWX)="S":.01666,$E(PSOQX("DURATION",1),PSOLOWX)="W":10080,$E(PSOQX("DURATION",1),PSOLOWX)="L":43200,1:1440)
  1. .S PSOLOWER=PSOLOWXL*(+$G(PSOQX("DURATION",1)))
  1. S PSOLOWX=0 I +$G(PSOQX("DAYS SUPPLY")) S PSOLOWX=1440*+$G(PSOQX("DAYS SUPPLY"))
  1. Q:'$G(PSOLOWER)&('$G(PSOLOWX))
  1. S QTSH=$G(PSOQX("SCHEDULE",1)) D QTS Q:PSQQUIT!('$G(PSOFRQ))
  1. S PSOLOWST=$S('$G(PSOLOWER):$G(PSOLOWX),'$G(PSOLOWX):$G(PSOLOWER),$G(PSOLOWER)>$G(PSOLOWX):$G(PSOLOWX),$G(PSOLOWX)>$G(PSOLOWER):$G(PSOLOWER),$G(PSOLOWX)=$G(PSOLOWER):$G(PSOLOWER),1:0)
  1. Q:'$G(PSOLOWST)
  1. S PSQMIN=+$G(PSOLOWST)
  1. S PSQMINZ=PSQMIN/PSOFRQ
  1. S PSOQRND=PSQMINZ*+$G(PSOQX("DOSE ORDERED",1)) Q:'PSOQRND
  1. ;If DAYS SUPPLY was edited by Pharmacy and previous quantity was calculated, don't calculate/update quantity automatically
  1. I $G(PSODSEDT),'$$UPDQTY(PSOQRND+.9999\1) Q
  1. ;If DISPENSE DRUG was edited in Pharmacy and SIG contains "PRN" on a CS Order, don't calculate/update quantity automatically
  1. S PSORXDRG=$S($G(PSORXIEN):$P($G(PSORXED("RX0")),"^",6),1:$P($G(OR0),"^",9))
  1. I $D(PSORXIEN),PSORXDRG,PSORXDRG'=+$G(PSODRUG("IEN")),$G(QTYHLD),$$CSDS^PSOSIGDS(+$G(PSODRUG("IEN"))),$$PRN() D Q
  1. . W !!,"The Quantity (",$G(QTYHLD),") has not been changed."
  1. . W !,"Please review and update it if necessary.",!,$C(7)
  1. . N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
  1. D ROUND G QEND
  1. Q
  1. COMP ;COMPLEX DOSE HERE
  1. N PSOQEXC,PSOQAND,PSOQTHEN,PSQL,PSQMNL,PSQMNLX,PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSQ1,PSODUX,PSODUXX,PSODSMIN
  1. ;PSODUTOT = TOTAL OF ALL DURATIONS
  1. ;PSODUDIF = DIFF. OF DURATION VS DAYS SUPPLY
  1. ;PSODUMIS = # OF SEQUENCES MISSING A DURATION IF >1 CAN'T DEFAULT
  1. ;PSODUREP = SEQUENCE # THAT IS MISSING DURATION
  1. ;PSODSMIN = MINUTES OF DAYS SUPPLY
  1. S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND,PSOQTHEN,PSOQEXC)=0
  1. F PSQL=1:1:QDOSE S:$G(PSOQX("CONJUNCTION",PSQL))["A" PSOQAND=1 S:$G(PSOQX("CONJUNCTION",PSQL))["T" PSOQTHEN=1 S:$G(PSOQX("CONJUNCTION",PSQL))["X" PSOQEXC=1
  1. I $G(PSOQEXC) G QEND
  1. I $G(PSOQAND) G COMP^PSOSIGCX
  1. F PSQ1=1:1:QDOSE D Q:PSODUMIS>1
  1. .I '$G(PSOQX("DURATION",PSQ1)) S PSODUMIS=PSODUMIS+1,PSODUREP=PSQ1 Q
  1. .S PSODUX=$L(PSOQX("DURATION",PSQ1))
  1. .S PSODUXX=$S($E(PSOQX("DURATION",PSQ1),PSODUX)="M":1,$E(PSOQX("DURATION",PSQ1),PSODUX)="H":60,$E(PSOQX("DURATION",PSQ1),PSODUX)="S":.01666,$E(PSOQX("DURATION",PSQ1),PSODUX)="W":10080,$E(PSOQX("DURATION",PSQ1),PSODUX)="L":43200,1:1440)
  1. .S PSODUTOT=PSODUTOT+(PSODUXX*(+$G(PSOQX("DURATION",PSQ1))))
  1. G:PSODUMIS>1 QEND ; More than 1 sequence missing a duration
  1. I $G(PSODUMIS),'$G(PSOQX("DAYS SUPPLY")) G QEND ; missing 1 duration, no days supply
  1. S PSODSMIN=1440*+$G(PSOQX("DAYS SUPPLY"))
  1. I $G(PSODSMIN),$G(PSODSMIN)<$G(PSODUTOT) G QEND
  1. I '$G(PSODUMIS),$G(PSODSMIN),$G(PSODUTOT)>$G(PSODSMIN) G QEND ; no missing durations, but total durations are greater than days supply
  1. I $G(PSODUMIS),$G(PSODSMIN),$G(PSODSMIN)'>$G(PSODUTOT) G QEND ; 1 missing duration, and total of other durations are not less than days supply
  1. I '$G(PSODSMIN),$G(PSODUMIS) G QEND ; no days supply, missing a duration
  1. I $G(PSODUREP) S PSODUDIF=$G(PSODSMIN)-$G(PSODUTOT)
  1. F PSQ=1:1:QDOSE D Q:$G(PSQQUIT)
  1. .I '$G(PSOQX("DOSE ORDERED",PSQ))!($G(PSOQX("SCHEDULE",PSQ))="") S PSQQUIT=1 Q
  1. .S QTSH=$G(PSOQX("SCHEDULE",PSQ)) D QTS S:'$G(PSOFRQ) PSQQUIT=1 Q:$G(PSQQUIT)
  1. .I $G(PSOQX("DURATION",PSQ)) S PSQMNL=$L(PSOQX("DURATION",PSQ)) D
  1. ..S PSQMNLX=$S($E(PSOQX("DURATION",PSQ),PSQMNL)="M":1,$E(PSOQX("DURATION",PSQ),PSQMNL)="H":60,$E(PSOQX("DURATION",PSQ),PSQMNL)="S":.01666,$E(PSOQX("DURATION",PSQ),PSQMNL)="W":10080,$E(PSOQX("DURATION",PSQ),PSQMNL)="L":43200,1:1440)
  1. ..S PSQMIN=PSQMNLX*(+$G(PSOQX("DURATION",PSQ)))
  1. .I '$G(PSOQX("DURATION",PSQ)) S PSQMIN=$G(PSODUDIF)
  1. .S PSQMINZ=PSQMIN/PSOFRQ
  1. .S PSOQRND=$S('$G(PSOQRND):PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ)),1:$G(PSOQRND)+(PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ))))
  1. I $G(PSQQUIT) G QEND
  1. ;If DAYS SUPPLY was edited by Pharmacy, don't re-calculate QTY automatically for Digitally Signed Pending Orders
  1. I $G(PSODSEDT),$G(QTYHLD),$G(PSOFDR),$P($G(OR0),"^",24) D Q
  1. . W !!,"The Quantity (",QTYHLD,") has not been changed."
  1. . W !,"Please review and update it if necessary.",!,$C(7)
  1. . N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
  1. I $G(PSOQRND) D ROUND
  1. G QEND
  1. QTS ;*282 Preserve Old Functionality
  1. S PSOFRQ=$$QTSCH(QTSH)
  1. I '$G(PSOFRQ) S PSQQUIT=1
  1. Q
  1. ;
  1. QTSCH(QTSH) ;
  1. ; Return Frequency for Schedule QTSH
  1. ; Otherwise return ""
  1. N PSOFRQ,SPCT,FOUND
  1. Q:$G(QTSH)="" ""
  1. Q:$E(QTSH,1)=" " ""
  1. S QTSH=$$UPPER(QTSH)
  1. S SPCT=1,PSOFRQ=0 F I=1:1:$L(QTSH) I $E(QTSH,I)=" " S SPCT=SPCT+1
  1. F I=0:1:SPCT-1 S SCHTMP=$P(QTSH," ",1,SPCT-I) Q:PSOFRQ D
  1. . F II=0:0 S II=$O(^PS(51.1,"APPSJ",SCHTMP,II)) Q:'II!PSOFRQ S PSOFRQ=$P(^PS(51.1,II,0),"^",3)
  1. Q:PSOFRQ PSOFRQ
  1. F I=0:1:SPCT-1 S SCHTMP=$P(QTSH," ",1,SPCT-I) Q:PSOFRQ D
  1. . F II=0:0 S II=$O(^PS(51,"B",SCHTMP,II)) Q:'II!PSOFRQ I $P(^PS(51,II,0),"^",4)<2 S PSOFRQ=$P(^PS(51,II,0),"^",8)
  1. Q:PSOFRQ PSOFRQ
  1. Q ""
  1. ;
  1. QEND ;
  1. ; PSOMTFLG variable indicates a Maintenance Rx (Titration/Maintenance)
  1. ; PSO*7.0*574 ;Defect 1155637
  1. K PSOFRQ
  1. I $G(PSOOUTQT),$G(QTYHLD),$G(PSOQX("QTY")),$G(QTYHLD)'=$G(PSOQX("QTY")) D I '$G(PSOMTFLG) W ! N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
  1. .W:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),U)'="PSOCLO1" !!,"Quantity has been changed from "_QTYHLD_" to "_PSOQX("QTY")
  1. .I $G(PSONEW("FLD"))=8,$P($G(OR0),"^",24),$G(PSODRUG("IEN")),$D(^PSDRUG(+$G(PSODRUG("IEN")),0)) D
  1. ..I $P(^PSDRUG(PSODRUG("IEN"),0),"^",3)[2!($P(^PSDRUG(PSODRUG("IEN"),0),"^",3)["F") Q
  1. ..N ZRFA S ZRFA=$S($G(CLOZPAT)=2&(PSOQX("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSOQX("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSOQX("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5)
  1. ..N ZREF,ZTQ S ZREF=QTYHLD\PSOQX("QTY") I ZREF>0 D
  1. ...S ZTQ=QTYHLD*(PSOQX("# OF REFILLS")+1),ZTQ=ZTQ-PSOQX("QTY"),ZREF=ZTQ\PSOQX("QTY") S:ZREF>ZRFA ZREF=ZRFA
  1. ...I ZREF'=PSOQX("# OF REFILLS") W !,"# of Refills has been changed from "_PSOQX("# OF REFILLS")_" to "_ZREF S PSOQX("# OF REFILLS")=ZREF
  1. Q
  1. ROUND ;
  1. Q:'$G(PSOQRND)
  1. Q:$$PRN() ;584 - Do not create a default quantity for a PRN prescription
  1. I PSOQRND'["." S PSOQX("QTY")=PSOQRND Q
  1. S PSOQX("QTY")=$P(PSOQRND,".")+1
  1. Q
  1. DAY(DATE) ;First 5 digits of FileMan date
  1. N X
  1. I DATE'?5N Q -1
  1. S X=$E(DATE,4,5) I X<1!(X>12) Q -1
  1. S X=DATE+1+(X=12*88)_"01"
  1. Q $E($$FMADD^XLFDT(X,-1),6,7)
  1. ;
  1. QTYX(PSOQX) ;
  1. N PSOQLP,PSOQLN,PSOQAR,PSOCPRQT,QDOSE,QDOSEX S PSOCPRQT=1 F PSOQLP=0:0 S PSOQLP=$O(PSOQX("DURATION",PSOQLP)) Q:'PSOQLP D
  1. .S PSOQAR("DURATION",PSOQLP)=$G(PSOQX("DURATION",PSOQLP))
  1. .I $E(PSOQX("DURATION",PSOQLP))?1A S PSOQLN=$L(PSOQX("DURATION",PSOQLP)) S PSOQX("DURATION",PSOQLP)=$E(PSOQX("DURATION",PSOQLP),2,PSOQLN)_$E(PSOQX("DURATION",PSOQLP))
  1. S QDOSE=0 F QDOSEX=0:0 S QDOSEX=$O(PSOQX("DOSE ORDERED",QDOSEX)) Q:'QDOSEX S QDOSE=QDOSE+1
  1. I '$G(PSOQX("QTY")) D QTYCP G QPASS
  1. D QTYCP^PSOSIGDS
  1. QPASS F PSOQLP=0:0 S PSOQLP=$O(PSOQAR("DURATION",PSOQLP)) Q:'PSOQLP D
  1. .S PSOQX("DURATION",PSOQLP)=$G(PSOQAR("DURATION",PSOQLP))
  1. K PSOCPRQT
  1. Q
  1. DAYS(PSOQX) ;Entry point for Days Supply calc for PSO
  1. ;Kill days supply here
  1. Q:'$G(PSOQX("QTY"))
  1. D QTYOPS^PSOSIGDS
  1. Q
  1. ;
  1. UPDQTY(NEWQTY) ; If DAYS SUPPLY is being edited and previous QTY was not calculated, don't calculate and update QTY
  1. ; Also, if digitally signed, do not automatically calculate and update quantity if QTY increases
  1. ; Input: NEWQTY - Newly Calculated Quantity
  1. ;Output: 1: YES - Update Rx with re-calculated QTY / 0: NO - Don't update Rx with re-calculated QTY
  1. N UPDQTY,PSOFREQ,PSOOLDDS,PSONEWDS,PSOOLDQT,PSODOSOR,PSODUR
  1. S UPDQTY=1 I 'NEWQTY Q UPDQTY
  1. S PSOOLDDS=$G(PSOQX("DAYS SUPPLY OLD")) I 'PSOOLDDS Q UPDQTY ; DAYS SUPPLY value prior to edit
  1. S PSONEWDS=$G(PSOQX("DAYS SUPPLY")) I 'PSONEWDS Q UPDQTY ; New DAYS SUPPLY value
  1. S PSOOLDQT=$G(QTYHLD) I 'PSOOLDQT Q UPDQTY ; QTY on file, possibly calculated
  1. S PSOFREQ=$$SCHFREQ(),PSODOSOR=$G(PSOQX("DOSE ORDERED",1))
  1. S PSODUR=$G(PSOQX("DURATION",1)) I PSODUR,PSODUR<PSOOLDDS S PSOOLDDS=PSODUR
  1. ;
  1. ;Checking whether current QTY was previously calculated, if not don't update with new QTY
  1. I (PSODOSOR<1)!(PSOFREQ>1440) D
  1. . ;Different calculation for doses of less than one QTY (e.g., 1/2 tablet) OR frequency less than every 24hrs (e.g., every 72hrs)
  1. . I PSOFREQ,(((PSOOLDDS*(1440/PSOFREQ))*PSODOSOR)+.9\1)'=PSOOLDQT S UPDQTY=0
  1. E D
  1. . ;Checking whether current QTY was previously calculated
  1. . I ((NEWQTY/PSONEWDS)'=(PSOOLDQT/PSOOLDDS)) S UPDQTY=0
  1. ;
  1. ;QTY is increasing for a CS Rx/Order, so don't update with new QTY
  1. I ($G(PSOFDR)&$P($G(OR0),"^",24)&(NEWQTY>PSOOLDQT)) S UPDQTY=0
  1. ;
  1. I 'UPDQTY D
  1. . W !!,"The Quantity (",PSOOLDQT,") has not been changed."
  1. . W !,"Please review and update it if necessary.",!,$C(7)
  1. . N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
  1. Q UPDQTY
  1. ;
  1. SCHFREQ() ; Returns the Frequency (in minutes) for the schedule
  1. ; Output: SCHFREQ - Schedule Frequency (in minutes)
  1. N SCHED,SCHEDIEN
  1. S SCHED=$G(PSOQX("SCHEDULE",1)) I SCHED="" Q 0
  1. S SCHEDIEN=$O(^PS(51.1,"B",SCHED,0)) I SCHEDIEN Q $$GET1^DIQ(51.1,SCHEDIEN,2)
  1. S SCHEDIEN=$O(^PS(51,"B",SCHED,0)) I SCHEDIEN Q $$GET1^DIQ(51,SCHEDIEN,31)
  1. Q 0
  1. ;
  1. PRN() ; Returns if the Schedule is PRN (1) or not (0)
  1. N PRN,SCH S PRN=0
  1. F SCH=1:1 Q:'$D(PSOQX("SCHEDULE",SCH)) I $G(PSOQX("SCHEDULE",SCH))["PRN" S PRN=1 Q
  1. Q PRN
  1. ;
  1. UPPER(PSOSCUP) ;
  1. Q $TR(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")