PSOSIGCX ;BIR/RTR-Utility to calculate quantity ;6/04/00
;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997
;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 ;SCH = schedule entered SCHEX = expanded schedule
N SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST
K SCHEX S SQFLAG=0
I $G(SCH)="" S SCHEX="" Q
I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
F SCLOOP=0:0 S SCLOOP=$O(^PS(51.1,"B",SCH,SCLOOP)) Q:'SCLOOP!(SQFLAG) I $P($G(^PS(51.1,SCLOOP,0)),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SQFLAG=1
Q:SQFLAG
I $P($G(^PS(51,"A",SCH)),"^")'="" S SCHEX=$P(^(SCH),"^") Q
S SCLOOP=0 F SCLP=1:1:$L(SCH) S SCLPS=$E(SCH,SCLP) I SCLPS=" " S SCLOOP=SCLOOP+1
I SCLOOP=0 S SCHEX=SCH Q
S SCLOOP=SCLOOP+1
K SCLHOLD F SCIN=1:1:SCLOOP S (SODL,SCLHOLD(SCIN))=$P(SCH," ",SCIN) D
.Q:$G(SODL)=""
.S SQFLAG=0 F SST=0:0 S SST=$O(^PS(51.1,"B",SODL,SST)) Q:'SST!($G(SQFLAG)) I $P($G(^PS(51.1,SST,0)),"^",8)'="" S SCLHOLD(SCIN)=$P($G(^(0)),"^",8),SQFLAG=1
.Q:$G(SQFLAG)
.I $P($G(^PS(51,"A",SODL)),"^")'="" S SCLHOLD(SCIN)=$P(^(SODL),"^")
S SCHEX="",SQFLAG=0 F SST=1:1:SCLOOP S SCHEX=SCHEX_$S($G(SQFLAG):" ",1:"")_$G(SCLHOLD(SST)),SQFLAG=1
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
Q:'$G(PSOQX("DOSE ORDERED",1))
Q:'$G(PSOQX("DAYS SUPPLY"))&('$G(PSOQX("DURATION",1)))
S PSOLOWER=0
I $G(PSOQX("DURATION",1)) D
.S PSOLOWX=$L(PSOQX("DURATION",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)
.S PSOLOWER=PSOLOWXL*(+$G(PSOQX("DURATION",1)))
S PSOLOWX=0 I +$G(PSOQX("DAYS SUPPLY")) S PSOLOWX=1440*+$G(PSOQX("DAYS SUPPLY"))
Q:'$G(PSOLOWER)&('$G(PSOLOWX))
S QTSH=$G(PSOQX("SCHEDULE",1)) 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)
S PSQMIN=+$G(PSOLOWST)
S PSQMINZ=PSQMIN/PSOFRQ
S PSOQRND=PSQMINZ*+$G(PSOQX("DOSE ORDERED",1)) Q:'PSOQRND
D ROUND G QEND
Q
COMP ;COMPLEX DOSE HERE - ALL ANDS
;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 PSODUMSS,PSODSAME,PSODURT S (PSODUMSS,PSODSAME,PSODURT)=0
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)
.S PSODUTOT=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(PSODSMIN),$G(PSODSMIN)<$G(PSODUTOT) G QEND
;I '$G(PSODUMIS),$G(PSODSMIN),$G(PSODUTOT)>$G(PSODSMIN) G QEND ; no missing durations, but total durations are greater than days supply
;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
;I '$G(PSODSMIN),$G(PSODUMIS) G QEND ; no days supply, m;issing a duration
;I $G(PSODUMIS),PSODUMSS S PSODUDIF=$G(PSODSMIN)-$G(PSODUTOT)
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(PSOQX("DURATION",PSQ)) S PSQMIN=$S($G(PSODURT)&('$G(PSODSAME)):$G(PSODURT),1:$G(PSODSMIN))
.S PSQMINZ=PSQMIN/PSOFRQ
.S PSOQRND=$S('$G(PSOQRND):PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ)),1:$G(PSOQRND)+(PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ))))
I $G(PSQQUIT) G QEND
I $G(PSOQRND) D ROUND
G QEND
QTS ;Find frequency
;QTSH = SHCEDULE
;either return PSOFRQ for frequency or PSSQUIT for no frequency
N SQTFLAG,SQQT,ZZQT,ZZQ,ZZQQ,ZQHOLD,QGLFLAG,PZQT,ZDL,ZZQX
K PSOFRQ
S (QGLFLAG,ZZQX)=0
I $G(QTSH)="" S PSQQUIT=1 Q
S SQTFLAG=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG)) I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),SQTFLAG=1
Q:SQTFLAG
F SQQT=0:0 S SQQT=$O(^PS(51,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG)) I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),SQTFLAG=1
Q:SQTFLAG
S ZZQT=0 F ZZQ=1:1:$L(QTSH) S ZZQQ=$E(QTSH,ZZQ) I ZZQQ=" " S ZZQT=ZZQT+1
I 'ZZQT S PSQQUIT=1 Q
S ZZQT=ZZQT+1
K ZQHOLD S QGLFLAG=0 F PZQT=1:1:ZZQT S (ZDL,ZQHOLD)=$P(QTSH," ",PZQT) D
.Q:$G(ZDL)=""
.S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX)) I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),ZZQX=1,QGLFLAG=QGLFLAG+1
.Q:ZZQX
.S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX)) I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),ZZQX=1,QGLFLAG=QGLFLAG+1
I $G(QGLFLAG)>1 K PSOFRQ
I '$G(PSOFRQ) S PSQQUIT=1
Q
QEND ;
K PSOFRQ
Q
ROUND ;
Q:'$G(PSOQRND)
I PSOQRND'["." S PSOQX("QTY")=PSOQRND Q
S PSOQX("QTY")=$P(PSOQRND,".")+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
PSOSIGCX ;BIR/RTR-Utility to calculate quantity ;6/04/00
+1 ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997
+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 ;SCH = schedule entered SCHEX = expanded schedule
+1 NEW SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST
+2 KILL SCHEX
SET SQFLAG=0
+3 IF $GET(SCH)=""
SET SCHEX=""
QUIT
+4 IF SCH[""""!($ASCII(SCH)=45)!(SCH?.E1C.E)!($LENGTH(SCH," ")>3)!($LENGTH(SCH)>20)!($LENGTH(SCH)<1)
KILL SCH
QUIT
+5 FOR SCLOOP=0:0
SET SCLOOP=$ORDER(^PS(51.1,"B",SCH,SCLOOP))
IF 'SCLOOP!(SQFLAG)
QUIT
IF $PIECE($GET(^PS(51.1,SCLOOP,0)),"^",8)'=""
SET SCHEX=$PIECE($GET(^(0)),"^",8)
SET SQFLAG=1
+6 IF SQFLAG
QUIT
+7 IF $PIECE($GET(^PS(51,"A",SCH)),"^")'=""
SET SCHEX=$PIECE(^(SCH),"^")
QUIT
+8 SET SCLOOP=0
FOR SCLP=1:1:$LENGTH(SCH)
SET SCLPS=$EXTRACT(SCH,SCLP)
IF SCLPS=" "
SET SCLOOP=SCLOOP+1
+9 IF SCLOOP=0
SET SCHEX=SCH
QUIT
+10 SET SCLOOP=SCLOOP+1
+11 KILL SCLHOLD
FOR SCIN=1:1:SCLOOP
SET (SODL,SCLHOLD(SCIN))=$PIECE(SCH," ",SCIN)
Begin DoDot:1
+12 IF $GET(SODL)=""
QUIT
+13 SET SQFLAG=0
FOR SST=0:0
SET SST=$ORDER(^PS(51.1,"B",SODL,SST))
IF 'SST!($GET(SQFLAG))
QUIT
IF $PIECE($GET(^PS(51.1,SST,0)),"^",8)'=""
SET SCLHOLD(SCIN)=$PIECE($GET(^(0)),"^",8)
SET SQFLAG=1
+14 IF $GET(SQFLAG)
QUIT
+15 IF $PIECE($GET(^PS(51,"A",SODL)),"^")'=""
SET SCLHOLD(SCIN)=$PIECE(^(SODL),"^")
End DoDot:1
+16 SET SCHEX=""
SET SQFLAG=0
FOR SST=1:1:SCLOOP
SET SCHEX=SCHEX_$SELECT($GET(SQFLAG):" ",1:"")_$GET(SCLHOLD(SST))
SET SQFLAG=1
+17 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
+9 IF '$GET(PSOQX("DOSE ORDERED",1))
QUIT
+10 IF '$GET(PSOQX("DAYS SUPPLY"))&('$GET(PSOQX("DURATION",1)))
QUIT
+11 SET PSOLOWER=0
+12 IF $GET(PSOQX("DURATION",1))
Begin DoDot:1
+13 SET PSOLOWX=$LENGTH(PSOQX("DURATION",1))
+14 SET PSOLOWXL=$SELECT($EXTRACT(PSOQX("DURATION",1),PSOLOWX)="M":1,$EXTRACT(PSOQX("DURATION",1),PSOLOWX)="H":60,$EXTRACT(PSOQX("DURATION",1),PSOLOWX)="S":.01666,...
... $EXTRACT(PSOQX("DURATION",1),PSOLOWX)="W":10080,$EXTRACT(PSOQX("DURATION",1),PSOLOWX)="L":43200,1:1440)
+15 SET PSOLOWER=PSOLOWXL*(+$GET(PSOQX("DURATION",1)))
End DoDot:1
+16 SET PSOLOWX=0
IF +$GET(PSOQX("DAYS SUPPLY"))
SET PSOLOWX=1440*+$GET(PSOQX("DAYS SUPPLY"))
+17 IF '$GET(PSOLOWER)&('$GET(PSOLOWX))
QUIT
+18 SET QTSH=$GET(PSOQX("SCHEDULE",1))
DO QTS
IF PSQQUIT!('$GET(PSOFRQ))
QUIT
+19 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)
+20 IF '$GET(PSOLOWST)
QUIT
+21 SET PSQMIN=+$GET(PSOLOWST)
+22 SET PSQMINZ=PSQMIN/PSOFRQ
+23 SET PSOQRND=PSQMINZ*+$GET(PSOQX("DOSE ORDERED",1))
IF 'PSOQRND
QUIT
+24 DO ROUND
GOTO QEND
+25 QUIT
COMP ;COMPLEX DOSE HERE - ALL ANDS
+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 IF $GET(PSOQTHEN)
GOTO COMP^PSOSIGTX
+12 NEW PSODUMSS,PSODSAME,PSODURT
SET (PSODUMSS,PSODSAME,PSODURT)=0
+13 FOR PSQ1=1:1:QDOSE
Begin DoDot:1
+14 IF '$GET(PSOQX("DURATION",PSQ1))
SET PSODUMIS=PSODUMIS+1
SET PSODUREP=PSQ1
QUIT
+15 SET PSODUX=$LENGTH(PSOQX("DURATION",PSQ1))
+16 SET PSODUMSS=1
+17 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)
+18 SET PSODUTOT=PSODUTOT+(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
+19 IF '$GET(PSODSAME)
IF $GET(PSODURT)
IF PSODURT'=(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
SET PSODSAME=1
+20 SET PSODURT=(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
End DoDot:1
+21 ;I PSODUMIS,PSODSAME G QEND ; missing durations, and other durations are all not the same
+22 ; missing Days Supply
IF '$GET(PSOQX("DAYS SUPPLY"))
GOTO QEND
+23 SET PSODSMIN=1440*+$GET(PSOQX("DAYS SUPPLY"))
+24 ; Missing Durations, other are different
IF PSODUMIS
IF PSODSAME
GOTO QEND
+25 ; 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
+26 ; 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
+27 ;I $G(PSODSMIN),$G(PSODSMIN)<$G(PSODUTOT) G QEND
+28 ;I '$G(PSODUMIS),$G(PSODSMIN),$G(PSODUTOT)>$G(PSODSMIN) G QEND ; no missing durations, but total durations are greater than days supply
+29 ;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
+30 ;I '$G(PSODSMIN),$G(PSODUMIS) G QEND ; no days supply, m;issing a duration
+31 ;I $G(PSODUMIS),PSODUMSS S PSODUDIF=$G(PSODSMIN)-$G(PSODUTOT)
+32 FOR PSQ=1:1:QDOSE
Begin DoDot:1
+33 IF '$GET(PSOQX("DOSE ORDERED",PSQ))!($GET(PSOQX("SCHEDULE",PSQ))="")
SET PSQQUIT=1
QUIT
+34 SET QTSH=$GET(PSOQX("SCHEDULE",PSQ))
DO QTS
IF '$GET(PSOFRQ)
SET PSQQUIT=1
IF $GET(PSQQUIT)
QUIT
+35 IF $GET(PSOQX("DURATION",PSQ))
SET PSQMNL=$LENGTH(PSOQX("DURATION",PSQ))
Begin DoDot:2
+36 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)
+37 SET PSQMIN=PSQMNLX*(+$GET(PSOQX("DURATION",PSQ)))
End DoDot:2
+38 IF '$GET(PSOQX("DURATION",PSQ))
SET PSQMIN=$SELECT($GET(PSODURT)&('$GET(PSODSAME)):$GET(PSODURT),1:$GET(PSODSMIN))
+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))))
End DoDot:1
IF $GET(PSQQUIT)
QUIT
+41 IF $GET(PSQQUIT)
GOTO QEND
+42 IF $GET(PSOQRND)
DO ROUND
+43 GOTO QEND
QTS ;Find frequency
+1 ;QTSH = SHCEDULE
+2 ;either return PSOFRQ for frequency or PSSQUIT for no frequency
+3 NEW SQTFLAG,SQQT,ZZQT,ZZQ,ZZQQ,ZQHOLD,QGLFLAG,PZQT,ZDL,ZZQX
+4 KILL PSOFRQ
+5 SET (QGLFLAG,ZZQX)=0
+6 IF $GET(QTSH)=""
SET PSQQUIT=1
QUIT
+7 SET SQTFLAG=0
FOR SQQT=0:0
SET SQQT=$ORDER(^PS(51.1,"B",QTSH,SQQT))
IF 'SQQT!($GET(SQTFLAG))
QUIT
IF $PIECE($GET(^PS(51.1,SQQT,0)),"^",3)
SET PSOFRQ=$PIECE($GET(^(0)),"^",3)
SET SQTFLAG=1
+8 IF SQTFLAG
QUIT
+9 FOR SQQT=0:0
SET SQQT=$ORDER(^PS(51,"B",QTSH,SQQT))
IF 'SQQT!($GET(SQTFLAG))
QUIT
IF $PIECE($GET(^PS(51,SQQT,0)),"^",8)
SET PSOFRQ=$PIECE($GET(^(0)),"^",8)
SET SQTFLAG=1
+10 IF SQTFLAG
QUIT
+11 SET ZZQT=0
FOR ZZQ=1:1:$LENGTH(QTSH)
SET ZZQQ=$EXTRACT(QTSH,ZZQ)
IF ZZQQ=" "
SET ZZQT=ZZQT+1
+12 IF 'ZZQT
SET PSQQUIT=1
QUIT
+13 SET ZZQT=ZZQT+1
+14 KILL ZQHOLD
SET QGLFLAG=0
FOR PZQT=1:1:ZZQT
SET (ZDL,ZQHOLD)=$PIECE(QTSH," ",PZQT)
Begin DoDot:1
+15 IF $GET(ZDL)=""
QUIT
+16 SET ZZQX=0
FOR SQQT=0:0
SET SQQT=$ORDER(^PS(51.1,"B",ZDL,SQQT))
IF 'SQQT!($GET(ZZQX))
QUIT
IF $PIECE($GET(^PS(51.1,SQQT,0)),"^",3)
SET PSOFRQ=$PIECE($GET(^(0)),"^",3)
SET ZZQX=1
SET QGLFLAG=QGLFLAG+1
+17 IF ZZQX
QUIT
+18 SET ZZQX=0
FOR SQQT=0:0
SET SQQT=$ORDER(^PS(51,"B",ZDL,SQQT))
IF 'SQQT!($GET(ZZQX))
QUIT
IF $PIECE($GET(^PS(51,SQQT,0)),"^",8)
SET PSOFRQ=$PIECE($GET(^(0)),"^",8)
SET ZZQX=1
SET QGLFLAG=QGLFLAG+1
End DoDot:1
+19 IF $GET(QGLFLAG)>1
KILL PSOFRQ
+20 IF '$GET(PSOFRQ)
SET PSQQUIT=1
+21 QUIT
QEND ;
+1 KILL PSOFRQ
+2 QUIT
ROUND ;
+1 IF '$GET(PSOQRND)
QUIT
+2 IF PSOQRND'["."
SET PSOQX("QTY")=PSOQRND
QUIT
+3 SET PSOQX("QTY")=$PIECE(PSOQRND,".")+1
+4 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
