- PSOSIGTX ;BIR/RTR - Utility to calculate quantity ;Sept 20, 2021@16:25
- ;;7.0;OUTPATIENT PHARMACY;**46,282,446,441**;DEC 1997;Build 208
- ;External reference to PS(51 supported by DBIA 2224
- ;External reference to PS(51.1 supported by DBIA 2225
- ;
- EN(PSOSIGX) ;
- N VARIABLE
- Q
- SCH ;*282 Centralized Call
- D SCH^PSOSIG
- Q
- QTY(PSOQX) ;
- N QDOSE
- QTYCP ;CPRS qty call comes through here
- N PSQQUIT,QTSH,PSQ,PSQMIN,PSQMINZ,PSOQRND,PSOLOWER,PSOLOWX,PSOLOWXL,PSOLOWST
- K PSOFRQ S PSQQUIT=0
- 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
- ;Q:PSQQUIT!('QDOSE)
- I '$G(PSOCPRQT) Q:PSQQUIT
- Q:'$G(PSOQX("DAYS SUPPLY"))
- Q:'$G(QDOSE)
- G:QDOSE>1 COMP
- TOP ;One Dose for complex and/then
- N PSOQDUR
- Q:'$G(PSOQX("DOSE ORDERED",PSQDOSE))
- Q:'$G(PSOQX("DAYS SUPPLY"))&('$G(PSOQX("DURATION",PSQDOSE)))
- S PSOLOWER=0
- I $G(PSOQX("DURATION",PSQDOSE)) D
- .S PSOLOWX=$L(PSOQX("DURATION",PSQDOSE))
- .S PSOQDUR=$G(PSOQX("DURATION",PSQDOSE))
- .S PSOLOWXL=$S($E(PSOQDUR,PSOLOWX)="M":1,$E(PSOQDUR,PSOLOWX)="H":60,$E(PSOQDUR,PSOLOWX)="S":.01666,$E(PSOQDUR,PSOLOWX)="W":10080,$E(PSOQDUR,PSOLOWX)="L":43200,1:1440)
- .S PSOLOWER=PSOLOWXL*(+$G(PSOQX("DURATION",PSQDOSE)))
- I $G(PSOLOWER),$G(PSOLOWER)>PSODSMXX Q
- S PSOLOWX=$G(PSODSMXX)
- Q:'$G(PSOLOWER)&('$G(PSOLOWX))
- S QTSH=$G(PSOQX("SCHEDULE",PSQDOSE)) D QTS Q:PSQQUIT!('$G(PSOFRQ))
- 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)
- Q:'$G(PSOLOWST)
- Q:PSOLOWST'>0
- S PSQMIN=+$G(PSOLOWST)
- S PSQMINZ=PSQMIN/PSOFRQ
- S PSOQRND=PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQDOSE)) Q:'PSOQRND
- S PSODSMXX=PSODSMXX-PSQMIN
- Q:PSODSMXX<0
- D ROUND G QEND
- Q
- COMP ;COMPLEX DOSE HERE - ANDS AND THENS
- ;N PSOQAND,PSQL,PSQMNL,PSQMNLX,PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSQ1,PSODUX,PSODUXX,PSODSMIN
- ;PSODUTOT = TOTAL OF ALL DURATIONS
- ;PSODUDIF = DIFF. OF DURATION VS DAYS SUPPLY
- ;PSODUMIS = # OF SEQUENCES MISSING A DURATION IF >1 CAN'T DEFAULT
- ;PSODUREP = SEQUENCE # THAT IS MISSING DURATION
- ;PSODSMIN = MINUTES OF DAYS SUPPLY
- ;PSODSAME = FLAG THAT TELL IF DURATIONS ARE THE SAME
- ;PSODURT = DURATION MINUTES FOR COMPARE
- ;S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND)=0
- ;F PSQL=1:1:QDOSE S:$G(PSOQX("CONJUNCTION",PSQL))["A" PSOQAND=1 Q:PSOQAND
- ;I $G(PSOQTHEN) G COMP^PSOSIGTX
- N PSODSMIN,PSODUDIF,PSODUMIS,PSODUREP,PSODUTOT,PSODUX,PSODUXX,PSQ1,PSQMNL,PSQMNLX
- N PSQHOLDX,PSQFLAG,PSQMINLP,PSQMINAR,PSODSMXX,PSOTFLAG,PSODSDEC,PSORNDXX,PSOATQUT,PSQDOSE,PSQDOSEX,PSOQZ,PSOQZX S (PSORNDXX,PSOATQUT,PSODSDEC,PSOTFLAG)=0,PSQDOSE=0,PSQDOSEX=QDOSE
- I '$D(PSOQX("CONJUNCTION",PSQDOSEX)) S PSOQX("CONJUNCTION",PSQDOSEX)="A",PSOTFLAG=1
- S (PSODSMIN,PSODSMXX)=1440*+$G(PSOQX("DAYS SUPPLY"))
- ;F S PSQDOSE=$O(PSOQX("CONJUNCTION",PSQDOSE)) Q:$G(PSOATQUT)!($G(PSQDOSE)="") I $G(PSOQX("CONJUNCTION",PSQDOSE))["T"!(PSQDOSE=PSQDOSEX) S PSOATQUT=1 D
- ;.;I 1 DO TOP ELSE DO BELOW, SET BEGINNIG AND END COUNTERS, USE THOSE ON LOOPS BELOW, OR THE SINGLE NUMBER FOR UP TOP (CHANGE 1'S TO NUMBERS)
- ;.;I '$G(PSOQZ) S PSOQZ=1
- ;.;I PSQDOSE-PSOQZ=0 D TOP S PSOQZ=PSQDOSE+1 Q
- D BOT
- ;.S PSOQZ=PSQDOSE+1
- ;
- ;If DAYS SUPPLY was edited by Pharmacy, don't re-calculate QTY automatically for Digitally Signed Pending Orders
- I $G(PSODSEDT),$G(QTYHLD),$G(PSOFDR),$P($G(OR0),"^",24) D Q
- . W !!,"The Quantity (",QTYHLD,") has not been changed."
- . W !,"Please review and update it if necessary.",!,$C(7)
- . N DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W !
- . K PSOQX("QTY")
- ;
- ;SET LAST CONJUNCTION, MAKE SURE IT'S NOT PASSED IN FROM cprs
- I $G(PSOTFLAG) K PSOQX("CONJUNCTION",PSQDOSEX)
- I PSOATQUT K PSOQX("QTY") Q
- I $G(PSOQX("QTY")) D ROUNDF
- Q
- BOT ;
- N PSODUMSS,PSODSAME,PSODURT S (PSODUMSS,PSODSAME,PSODURT,PSODUMIS,PSOQRND,PSODUTOT)=0
- ;F PSQ1=PSOQZ:1:QDOSE D
- F PSQ1=1:1:QDOSE D
- .I '$G(PSOQX("DURATION",PSQ1)) S PSODUMIS=PSODUMIS+1,PSODUREP=PSQ1 Q
- .S PSODUX=$L(PSOQX("DURATION",PSQ1))
- .S PSODUMSS=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)
- . ;441 MWA all "Ands" should pick largest duration...not add durations
- .N PREVCONJ,PSODIFF S PREVCONJ=$G(PSOQX("CONJUNCTION",PSQ1-1))
- .I PREVCONJ="A" D
- ..N PREVDUX,PREVDUXX
- ..S PREVDUX=$L($G(PSOQX("DURATION",PSQ1-1))),PREVDUX(1)=$G(PSOQX("DURATION",PSQ1-1))
- ..I '+PREVDUX!('+PREVDUX(1)) Q
- ..S PREVDUXX=$S($E(PREVDUX(1),PREVDUX)="M":1,$E(PREVDUX(1),PREVDUX)="H":60,$E(PREVDUX(1),PREVDUX)="S":.01666,$E(PREVDUX(1),PREVDUX)="W":10080,$E(PREVDUX(1),PREVDUX)="L":43200,1:1440)
- ..I (+PREVDUX(1)*PREVDUXX)>(PSODUXX*(+$G(PSOQX("DURATION",PSQ1)))) S PSQMINAR(PSQ1)=0 Q
- ..S PSODIFF=((PSODUXX*(+$G(PSOQX("DURATION",PSQ1))))-(+PREVDUX(1)*PREVDUXX))
- ..S PSODUTOT=PSODUTOT+PSODIFF,PSQMINAR(PSQ1)=PSODIFF
- .I PREVCONJ="T" S PSODIFF=(PSODUXX*(+$G(PSOQX("DURATION",PSQ1)))) S PSODUTOT=PSODUTOT+PSODIFF,PSQMINAR(PSQ1)=PSODIFF
- .I PREVCONJ="" S PSODUTOT=PSODUXX*(+$G(PSOQX("DURATION",PSQ1)))
- .I '$G(PSODSAME),$G(PSODURT),PSODURT'=(PSODUXX*(+$G(PSOQX("DURATION",PSQ1)))) S PSODSAME=1
- .S PSODURT=(PSODUXX*(+$G(PSOQX("DURATION",PSQ1))))
- ;I PSODUMIS,PSODSAME G QEND ; missing durations, and other durations are all not the same
- I '$G(PSOQX("DAYS SUPPLY")) G QEND ; missing Days Supply
- ;S PSODSMIN=1440*+$G(PSOQX("DAYS SUPPLY"))
- I PSODUMIS,PSODSAME G QEND ; Missing Durations, other are different
- I 'PSODUMIS,PSODSAME,$G(PSODUTOT)>PSODSMIN G QEND ; Every sequence has a duration, some are different, and the total is greater than Days Supply
- I 'PSODSAME,PSODURT>PSODSMIN G QEND ; All have a duration, and it's the same, but it's greater than Days Supply, or Missing Durations with other duration the same but greater than Days Supply
- I $G(PSODUMIS),PSODUMSS S PSODUDIF=$G(PSODSMIN)-$G(PSODUTOT)
- ;K PSQMINAR
- ;F PSQ=PSOQZ:1:QDOSE D Q:$G(PSQQUIT)
- F PSQ=1:1:QDOSE D Q:$G(PSQQUIT)
- .I '$G(PSOQX("DOSE ORDERED",PSQ))!($G(PSOQX("SCHEDULE",PSQ))="") S PSQQUIT=1 Q
- .S QTSH=$G(PSOQX("SCHEDULE",PSQ)) D QTS S:'$G(PSOFRQ) PSQQUIT=1 Q:$G(PSQQUIT)
- .I $G(PSOQX("DURATION",PSQ)) S PSQMNL=$L(PSOQX("DURATION",PSQ)) D
- ..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)
- ..S PSQMIN=PSQMNLX*(+$G(PSOQX("DURATION",PSQ)))
- .;.I $G(PSQMIN) S PSQMINAR(PSQ)=PSQMIN
- .I '$G(PSOQX("DURATION",PSQ)) S PSQMIN=$S($G(PSODURT)&('$G(PSODSAME)):$G(PSODURT),1:$G(PSODSMXX)) I PSQMIN S PSQMINAR(PSQ)=PSQMIN
- .S PSQMINZ=PSQMIN/PSOFRQ
- .S PSOQRND=$S('$G(PSOQRND):PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ)),1:$G(PSOQRND)+(PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ))))
- .;S PSODSMXX=PSODSMXX-PSQMIN
- S (PSQFLAG,PSQHOLDX)=0 S PSQMINLP="" F S PSQMINLP=$O(PSQMINAR(PSQMINLP)) Q:PSQMINLP="" S:$G(PSQHOLDX)&($G(PSQHOLDX)'=$G(PSQMINAR(PSQMINLP))) PSQFLAG=1 S PSQHOLDX=$G(PSQMINAR(PSQMINLP))
- I $G(PSQFLAG) S PSQMINLP="" F S PSQMINLP=$O(PSQMINAR(PSQMINLP)) Q:PSQMINLP="" I $G(PSQMINAR(PSQMINLP)) S PSODSMXX=PSODSMXX-PSQMINAR(PSQMINLP)
- I '$G(PSQFLAG) S PSQMINLP="" F S PSQMINLP=$O(PSQMINAR(PSQMINLP)) Q:PSQMINLP=""!($G(PSQFLAG)) I $G(PSQMINAR(PSQMINLP)) S PSODSMXX=PSODSMXX-PSQMINAR(PSQMINLP),PSQFLAG=1
- K PSQMINAR,PSQFLAG
- I PSODSMXX<0 G QEND
- I $G(PSQQUIT) G QEND
- I $G(PSOQRND) D ROUND
- G QEND
- QTS ;*282 Centralized call
- D QTS^PSOSIG
- Q
- QEND ;
- K PSOFRQ
- Q
- ROUND ;
- Q:'$G(PSOQRND)
- S PSOQX("QTY")=$G(PSOQX("QTY"))+$G(PSOQRND)
- S PSOATQUT=0
- Q
- ROUNDF ;
- I PSOQX("QTY")'["." Q
- S PSOQX("QTY")=$P(PSOQX("QTY"),".")+1
- Q
- DAY(DATE) ;First 5 digits of FileMan date
- N X
- I DATE'?5N Q -1
- S X=$E(DATE,4,5) I X<1!(X>12) Q -1
- S X=DATE+1+(X=12*88)_"01"
- Q $E($$FMADD^XLFDT(X,-1),6,7)
- ;
- QTYX(PSOQX) ;
- N PSOQLP,PSOQLN,PSOQAR,PSOCPRQT,QDOSE,QDOSEX S PSOCPRQT=1 F PSOQLP=0:0 S PSOQLP=$O(PSOQX("DURATION",PSOQLP)) Q:'PSOQLP D
- .S PSOQAR("DURATION",PSOQLP)=$G(PSOQX("DURATION",PSOQLP))
- .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))
- S QDOSE=0 F QDOSEX=0:0 S QDOSEX=$O(PSOQX("DOSE ORDERED",QDOSEX)) Q:'QDOSEX S QDOSE=QDOSE+1
- I '$G(PSOQX("QTY")) D QTYCP G QPASS
- D QTYCP^PSOSIGDS
- QPASS F PSOQLP=0:0 S PSOQLP=$O(PSOQAR("DURATION",PSOQLP)) Q:'PSOQLP D
- .S PSOQX("DURATION",PSOQLP)=$G(PSOQAR("DURATION",PSOQLP))
- K PSOCPRQT
- Q
- DAYS(PSOQX) ;Entry point for Days Supply calc for PSO
- ;Kill days supply here
- Q:'$G(PSOQX("QTY"))
- D QTYOPS^PSOSIGDS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSIGTX 8832 printed Feb 19, 2025@00:01:21 Page 2
- PSOSIGTX ;BIR/RTR - Utility to calculate quantity ;Sept 20, 2021@16:25
- +1 ;;7.0;OUTPATIENT PHARMACY;**46,282,446,441**;DEC 1997;Build 208
- +2 ;External reference to PS(51 supported by DBIA 2224
- +3 ;External reference to PS(51.1 supported by DBIA 2225
- +4 ;
- EN(PSOSIGX) ;
- +1 NEW VARIABLE
- +2 QUIT
- SCH ;*282 Centralized Call
- +1 DO SCH^PSOSIG
- +2 QUIT
- QTY(PSOQX) ;
- +1 NEW QDOSE
- QTYCP ;CPRS qty call comes through here
- +1 NEW PSQQUIT,QTSH,PSQ,PSQMIN,PSQMINZ,PSOQRND,PSOLOWER,PSOLOWX,PSOLOWXL,PSOLOWST
- +2 KILL PSOFRQ
- SET PSQQUIT=0
- +3 IF '$GET(PSOCPRQT)
- SET QDOSE=0
- FOR PSQ=0:0
- SET PSQ=$ORDER(PSOQX("DOSE",PSQ))
- if 'PSQ
- QUIT
- SET QDOSE=PSQ
- if '$GET(PSOQX("DOSE ORDERED",PSQ))
- SET PSQQUIT=1
- +4 ;Q:PSQQUIT!('QDOSE)
- +5 IF '$GET(PSOCPRQT)
- if PSQQUIT
- QUIT
- +6 if '$GET(PSOQX("DAYS SUPPLY"))
- QUIT
- +7 if '$GET(QDOSE)
- QUIT
- +8 if QDOSE>1
- GOTO COMP
- TOP ;One Dose for complex and/then
- +1 NEW PSOQDUR
- +2 if '$GET(PSOQX("DOSE ORDERED",PSQDOSE))
- QUIT
- +3 if '$GET(PSOQX("DAYS SUPPLY"))&('$GET(PSOQX("DURATION",PSQDOSE)))
- QUIT
- +4 SET PSOLOWER=0
- +5 IF $GET(PSOQX("DURATION",PSQDOSE))
- Begin DoDot:1
- +6 SET PSOLOWX=$LENGTH(PSOQX("DURATION",PSQDOSE))
- +7 SET PSOQDUR=$GET(PSOQX("DURATION",PSQDOSE))
- +8 SET PSOLOWXL=$SELECT($EXTRACT(PSOQDUR,PSOLOWX)="M":1,$EXTRACT(PSOQDUR,PSOLOWX)="H":60,$EXTRACT(PSOQDUR,PSOLOWX)="S":.01666,$EXTRACT(PSOQDUR,PSOLOWX)="W":10080,$EXTRACT(PSOQDUR,PSOLOWX)="L":43200,1:1440)
- +9 SET PSOLOWER=PSOLOWXL*(+$GET(PSOQX("DURATION",PSQDOSE)))
- End DoDot:1
- +10 IF $GET(PSOLOWER)
- IF $GET(PSOLOWER)>PSODSMXX
- QUIT
- +11 SET PSOLOWX=$GET(PSODSMXX)
- +12 if '$GET(PSOLOWER)&('$GET(PSOLOWX))
- QUIT
- +13 SET QTSH=$GET(PSOQX("SCHEDULE",PSQDOSE))
- DO QTS
- if PSQQUIT!('$GET(PSOFRQ))
- QUIT
- +14 SET PSOLOWST=$SELECT('$GET(PSOLOWER):$GET(PSOLOWX),'$GET(PSOLOWX):$GET(PSOLOWER),$GET(PSOLOWER)>$GET(PSOLOWX):$GET(PSOLOWX),$GET(PSOLOWX)>$GET(PSOLOWER):$GET(PSOLOWER),$GET(PSOLOWX)=$GET(PSOLOWER):$GET(PSOLOWER),1:0)
- +15 if '$GET(PSOLOWST)
- QUIT
- +16 if PSOLOWST'>0
- QUIT
- +17 SET PSQMIN=+$GET(PSOLOWST)
- +18 SET PSQMINZ=PSQMIN/PSOFRQ
- +19 SET PSOQRND=PSQMINZ*+$GET(PSOQX("DOSE ORDERED",PSQDOSE))
- if 'PSOQRND
- QUIT
- +20 SET PSODSMXX=PSODSMXX-PSQMIN
- +21 if PSODSMXX<0
- QUIT
- +22 DO ROUND
- GOTO QEND
- +23 QUIT
- COMP ;COMPLEX DOSE HERE - ANDS AND THENS
- +1 ;N PSOQAND,PSQL,PSQMNL,PSQMNLX,PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSQ1,PSODUX,PSODUXX,PSODSMIN
- +2 ;PSODUTOT = TOTAL OF ALL DURATIONS
- +3 ;PSODUDIF = DIFF. OF DURATION VS DAYS SUPPLY
- +4 ;PSODUMIS = # OF SEQUENCES MISSING A DURATION IF >1 CAN'T DEFAULT
- +5 ;PSODUREP = SEQUENCE # THAT IS MISSING DURATION
- +6 ;PSODSMIN = MINUTES OF DAYS SUPPLY
- +7 ;PSODSAME = FLAG THAT TELL IF DURATIONS ARE THE SAME
- +8 ;PSODURT = DURATION MINUTES FOR COMPARE
- +9 ;S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND)=0
- +10 ;F PSQL=1:1:QDOSE S:$G(PSOQX("CONJUNCTION",PSQL))["A" PSOQAND=1 Q:PSOQAND
- +11 ;I $G(PSOQTHEN) G COMP^PSOSIGTX
- +12 NEW PSODSMIN,PSODUDIF,PSODUMIS,PSODUREP,PSODUTOT,PSODUX,PSODUXX,PSQ1,PSQMNL,PSQMNLX
- +13 NEW PSQHOLDX,PSQFLAG,PSQMINLP,PSQMINAR,PSODSMXX,PSOTFLAG,PSODSDEC,PSORNDXX,PSOATQUT,PSQDOSE,PSQDOSEX,PSOQZ,PSOQZX
- SET (PSORNDXX,PSOATQUT,PSODSDEC,PSOTFLAG)=0
- SET PSQDOSE=0
- SET PSQDOSEX=QDOSE
- +14 IF '$DATA(PSOQX("CONJUNCTION",PSQDOSEX))
- SET PSOQX("CONJUNCTION",PSQDOSEX)="A"
- SET PSOTFLAG=1
- +15 SET (PSODSMIN,PSODSMXX)=1440*+$GET(PSOQX("DAYS SUPPLY"))
- +16 ;F S PSQDOSE=$O(PSOQX("CONJUNCTION",PSQDOSE)) Q:$G(PSOATQUT)!($G(PSQDOSE)="") I $G(PSOQX("CONJUNCTION",PSQDOSE))["T"!(PSQDOSE=PSQDOSEX) S PSOATQUT=1 D
- +17 ;.;I 1 DO TOP ELSE DO BELOW, SET BEGINNIG AND END COUNTERS, USE THOSE ON LOOPS BELOW, OR THE SINGLE NUMBER FOR UP TOP (CHANGE 1'S TO NUMBERS)
- +18 ;.;I '$G(PSOQZ) S PSOQZ=1
- +19 ;.;I PSQDOSE-PSOQZ=0 D TOP S PSOQZ=PSQDOSE+1 Q
- +20 DO BOT
- +21 ;.S PSOQZ=PSQDOSE+1
- +22 ;
- +23 ;If DAYS SUPPLY was edited by Pharmacy, don't re-calculate QTY automatically for Digitally Signed Pending Orders
- +24 IF $GET(PSODSEDT)
- IF $GET(QTYHLD)
- IF $GET(PSOFDR)
- IF $PIECE($GET(OR0),"^",24)
- Begin DoDot:1
- +25 WRITE !!,"The Quantity (",QTYHLD,") has not been changed."
- +26 WRITE !,"Please review and update it if necessary.",!,$CHAR(7)
- +27 NEW DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- WRITE !
- +28 KILL PSOQX("QTY")
- End DoDot:1
- QUIT
- +29 ;
- +30 ;SET LAST CONJUNCTION, MAKE SURE IT'S NOT PASSED IN FROM cprs
- +31 IF $GET(PSOTFLAG)
- KILL PSOQX("CONJUNCTION",PSQDOSEX)
- +32 IF PSOATQUT
- KILL PSOQX("QTY")
- QUIT
- +33 IF $GET(PSOQX("QTY"))
- DO ROUNDF
- +34 QUIT
- BOT ;
- +1 NEW PSODUMSS,PSODSAME,PSODURT
- SET (PSODUMSS,PSODSAME,PSODURT,PSODUMIS,PSOQRND,PSODUTOT)=0
- +2 ;F PSQ1=PSOQZ:1:QDOSE D
- +3 FOR PSQ1=1:1:QDOSE
- Begin DoDot:1
- +4 IF '$GET(PSOQX("DURATION",PSQ1))
- SET PSODUMIS=PSODUMIS+1
- SET PSODUREP=PSQ1
- QUIT
- +5 SET PSODUX=$LENGTH(PSOQX("DURATION",PSQ1))
- +6 SET PSODUMSS=1
- +7 SET PSODUXX=$SELECT($EXTRACT(PSOQX("DURATION",PSQ1),PSODUX)="M":1,$EXTRACT(PSOQX("DURATION",PSQ1),PSODUX)="H":60,...
- ... $EXTRACT(PSOQX("DURATION",PSQ1),PSODUX)="S":.01666,$EXTRACT(PSOQX("DURATION",PSQ1),PSODUX)="W":10080,$EXTRACT(PSOQX("DURATION",PSQ1),PSODUX)="L":43200,1:1440)
- +8 ;441 MWA all "Ands" should pick largest duration...not add durations
- +9 NEW PREVCONJ,PSODIFF
- SET PREVCONJ=$GET(PSOQX("CONJUNCTION",PSQ1-1))
- +10 IF PREVCONJ="A"
- Begin DoDot:2
- +11 NEW PREVDUX,PREVDUXX
- +12 SET PREVDUX=$LENGTH($GET(PSOQX("DURATION",PSQ1-1)))
- SET PREVDUX(1)=$GET(PSOQX("DURATION",PSQ1-1))
- +13 IF '+PREVDUX!('+PREVDUX(1))
- QUIT
- +14 SET PREVDUXX=$SELECT($EXTRACT(PREVDUX(1),PREVDUX)="M":1,$EXTRACT(PREVDUX(1),PREVDUX)="H":60,$EXTRACT(PREVDUX(1),PREVDUX)="S":.01666,$EXTRACT(PREVDUX(1),PREVDUX)="W":10080,$EXTRACT(PREVDUX(1),PREVDUX)="L":43200,1:1440)
- +15 IF (+PREVDUX(1)*PREVDUXX)>(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
- SET PSQMINAR(PSQ1)=0
- QUIT
- +16 SET PSODIFF=((PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))-(+PREVDUX(1)*PREVDUXX))
- +17 SET PSODUTOT=PSODUTOT+PSODIFF
- SET PSQMINAR(PSQ1)=PSODIFF
- End DoDot:2
- +18 IF PREVCONJ="T"
- SET PSODIFF=(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
- SET PSODUTOT=PSODUTOT+PSODIFF
- SET PSQMINAR(PSQ1)=PSODIFF
- +19 IF PREVCONJ=""
- SET PSODUTOT=PSODUXX*(+$GET(PSOQX("DURATION",PSQ1)))
- +20 IF '$GET(PSODSAME)
- IF $GET(PSODURT)
- IF PSODURT'=(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
- SET PSODSAME=1
- +21 SET PSODURT=(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
- End DoDot:1
- +22 ;I PSODUMIS,PSODSAME G QEND ; missing durations, and other durations are all not the same
- +23 ; missing Days Supply
- IF '$GET(PSOQX("DAYS SUPPLY"))
- GOTO QEND
- +24 ;S PSODSMIN=1440*+$G(PSOQX("DAYS SUPPLY"))
- +25 ; Missing Durations, other are different
- IF PSODUMIS
- IF PSODSAME
- GOTO QEND
- +26 ; Every sequence has a duration, some are different, and the total is greater than Days Supply
- IF 'PSODUMIS
- IF PSODSAME
- IF $GET(PSODUTOT)>PSODSMIN
- GOTO QEND
- +27 ; All have a duration, and it's the same, but it's greater than Days Supply, or Missing Durations with other duration the same but greater than Days Supply
- IF 'PSODSAME
- IF PSODURT>PSODSMIN
- GOTO QEND
- +28 IF $GET(PSODUMIS)
- IF PSODUMSS
- SET PSODUDIF=$GET(PSODSMIN)-$GET(PSODUTOT)
- +29 ;K PSQMINAR
- +30 ;F PSQ=PSOQZ:1:QDOSE D Q:$G(PSQQUIT)
- +31 FOR PSQ=1:1:QDOSE
- Begin DoDot:1
- +32 IF '$GET(PSOQX("DOSE ORDERED",PSQ))!($GET(PSOQX("SCHEDULE",PSQ))="")
- SET PSQQUIT=1
- QUIT
- +33 SET QTSH=$GET(PSOQX("SCHEDULE",PSQ))
- DO QTS
- if '$GET(PSOFRQ)
- SET PSQQUIT=1
- if $GET(PSQQUIT)
- QUIT
- +34 IF $GET(PSOQX("DURATION",PSQ))
- SET PSQMNL=$LENGTH(PSOQX("DURATION",PSQ))
- Begin DoDot:2
- +35 SET PSQMNLX=$SELECT($EXTRACT(PSOQX("DURATION",PSQ),PSQMNL)="M":1,$EXTRACT(PSOQX("DURATION",PSQ),PSQMNL)="H":60,$EXTRACT(PSOQX("DURATION",PSQ),PSQMNL)="S":.01666,...
- ... $EXTRACT(PSOQX("DURATION",PSQ),PSQMNL)="W":10080,$EXTRACT(PSOQX("DURATION",PSQ),PSQMNL)="L":43200,1:1440)
- +36 SET PSQMIN=PSQMNLX*(+$GET(PSOQX("DURATION",PSQ)))
- End DoDot:2
- +37 ;.I $G(PSQMIN) S PSQMINAR(PSQ)=PSQMIN
- +38 IF '$GET(PSOQX("DURATION",PSQ))
- SET PSQMIN=$SELECT($GET(PSODURT)&('$GET(PSODSAME)):$GET(PSODURT),1:$GET(PSODSMXX))
- IF PSQMIN
- SET PSQMINAR(PSQ)=PSQMIN
- +39 SET PSQMINZ=PSQMIN/PSOFRQ
- +40 SET PSOQRND=$SELECT('$GET(PSOQRND):PSQMINZ*+$GET(PSOQX("DOSE ORDERED",PSQ)),1:$GET(PSOQRND)+(PSQMINZ*+$GET(PSOQX("DOSE ORDERED",PSQ))))
- +41 ;S PSODSMXX=PSODSMXX-PSQMIN
- End DoDot:1
- if $GET(PSQQUIT)
- QUIT
- +42 SET (PSQFLAG,PSQHOLDX)=0
- SET PSQMINLP=""
- FOR
- SET PSQMINLP=$ORDER(PSQMINAR(PSQMINLP))
- if PSQMINLP=""
- QUIT
- if $GET(PSQHOLDX)&($GET(PSQHOLDX)'=$GET(PSQMINAR(PSQMINLP)))
- SET PSQFLAG=1
- SET PSQHOLDX=$GET(PSQMINAR(PSQMINLP))
- +43 IF $GET(PSQFLAG)
- SET PSQMINLP=""
- FOR
- SET PSQMINLP=$ORDER(PSQMINAR(PSQMINLP))
- if PSQMINLP=""
- QUIT
- IF $GET(PSQMINAR(PSQMINLP))
- SET PSODSMXX=PSODSMXX-PSQMINAR(PSQMINLP)
- +44 IF '$GET(PSQFLAG)
- SET PSQMINLP=""
- FOR
- SET PSQMINLP=$ORDER(PSQMINAR(PSQMINLP))
- if PSQMINLP=""!($GET(PSQFLAG))
- QUIT
- IF $GET(PSQMINAR(PSQMINLP))
- SET PSODSMXX=PSODSMXX-PSQMINAR(PSQMINLP)
- SET PSQFLAG=1
- +45 KILL PSQMINAR,PSQFLAG
- +46 IF PSODSMXX<0
- GOTO QEND
- +47 IF $GET(PSQQUIT)
- GOTO QEND
- +48 IF $GET(PSOQRND)
- DO ROUND
- +49 GOTO QEND
- QTS ;*282 Centralized call
- +1 DO QTS^PSOSIG
- +2 QUIT
- QEND ;
- +1 KILL PSOFRQ
- +2 QUIT
- ROUND ;
- +1 if '$GET(PSOQRND)
- QUIT
- +2 SET PSOQX("QTY")=$GET(PSOQX("QTY"))+$GET(PSOQRND)
- +3 SET PSOATQUT=0
- +4 QUIT
- ROUNDF ;
- +1 IF PSOQX("QTY")'["."
- QUIT
- +2 SET PSOQX("QTY")=$PIECE(PSOQX("QTY"),".")+1
- +3 QUIT
- DAY(DATE) ;First 5 digits of FileMan date
- +1 NEW X
- +2 IF DATE'?5N
- QUIT -1
- +3 SET X=$EXTRACT(DATE,4,5)
- IF X<1!(X>12)
- QUIT -1
- +4 SET X=DATE+1+(X=12*88)_"01"
- +5 QUIT $EXTRACT($$FMADD^XLFDT(X,-1),6,7)
- +6 ;
- QTYX(PSOQX) ;
- +1 NEW PSOQLP,PSOQLN,PSOQAR,PSOCPRQT,QDOSE,QDOSEX
- SET PSOCPRQT=1
- FOR PSOQLP=0:0
- SET PSOQLP=$ORDER(PSOQX("DURATION",PSOQLP))
- if 'PSOQLP
- QUIT
- Begin DoDot:1
- +2 SET PSOQAR("DURATION",PSOQLP)=$GET(PSOQX("DURATION",PSOQLP))
- +3 IF $EXTRACT(PSOQX("DURATION",PSOQLP))?1A
- SET PSOQLN=$LENGTH(PSOQX("DURATION",PSOQLP))
- SET PSOQX("DURATION",PSOQLP)=$EXTRACT(PSOQX("DURATION",PSOQLP),2,PSOQLN)_$EXTRACT(PSOQX("DURATION",PSOQLP))
- End DoDot:1
- +4 SET QDOSE=0
- FOR QDOSEX=0:0
- SET QDOSEX=$ORDER(PSOQX("DOSE ORDERED",QDOSEX))
- if 'QDOSEX
- QUIT
- SET QDOSE=QDOSE+1
- +5 IF '$GET(PSOQX("QTY"))
- DO QTYCP
- GOTO QPASS
- +6 DO QTYCP^PSOSIGDS
- QPASS FOR PSOQLP=0:0
- SET PSOQLP=$ORDER(PSOQAR("DURATION",PSOQLP))
- if 'PSOQLP
- QUIT
- Begin DoDot:1
- +1 SET PSOQX("DURATION",PSOQLP)=$GET(PSOQAR("DURATION",PSOQLP))
- End DoDot:1
- +2 KILL PSOCPRQT
- +3 QUIT
- DAYS(PSOQX) ;Entry point for Days Supply calc for PSO
- +1 ;Kill days supply here
- +2 if '$GET(PSOQX("QTY"))
- QUIT
- +3 DO QTYOPS^PSOSIGDS
- +4 QUIT