- PSOSIG ;BIR/RTR-Utility to create SIG ;6/04/00
- ;;7.0;OUTPATIENT PHARMACY;**46,99,114**;DEC 1997
- ;External reference to PS(51 supported by DBIA 2224
- ;External reference to PS(51.1 supported by DBIA 2225
- ;External reference to PSDRUG( supported by DBIA 221
- ;
- 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
- N PSOSCUP S SCH=$$UPPER(SCH)
- 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
- K PSOQX("QTY")
- N PSOQTYQT,PSOLPSD I $G(PSOFDR) S PSOQTYQT=0 D I $G(PSOQTYQT) Q
- .I $G(PSODRUG("IEN")),$D(^PSDRUG(+$G(PSODRUG("IEN")),0)) D I PSOQTYQT Q
- ..I $P(^PSDRUG(PSODRUG("IEN"),0),"^",3)[2!($P(^(0),"^",3)[3)!($P(^(0),"^",3)[4)!($P(^(0),"^",3)[5) S PSOQTYQT=1
- .S PSOLPSD="" F S PSOLPSD=$O(PSONEW("SCHEDULE",PSOLPSD)) Q:PSOLPSD=""!(PSOQTYQT) I $G(PSONEW("SCHEDULE",PSOLPSD))["PRN"!($G(PSONEW("SCHEDULE",PSOLPSD))["prn") S PSOQTYQT=1 Q
- N PSOOUTQT S PSOOUTQT=1
- 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
- N PSOQEXC,PSOQAND,PSOQTHEN,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
- S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND,PSOQTHEN,PSOQEXC)=0
- 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
- I $G(PSOQEXC) G QEND
- I $G(PSOQAND) G COMP^PSOSIGCX
- F PSQ1=1:1:QDOSE D Q:PSODUMIS>1
- .I '$G(PSOQX("DURATION",PSQ1)) S PSODUMIS=PSODUMIS+1,PSODUREP=PSQ1 Q
- .S PSODUX=$L(PSOQX("DURATION",PSQ1))
- .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))))
- G:PSODUMIS>1 QEND ; More than 1 sequence missing a duration
- I $G(PSODUMIS),'$G(PSOQX("DAYS SUPPLY")) G QEND ; missing 1 duration, no days supply
- S PSODSMIN=1440*+$G(PSOQX("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, missing a duration
- I $G(PSODUREP) 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=$G(PSODUDIF)
- .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
- I $G(PSOOUTQT),$G(QTYHLD),$G(PSOQX("QTY")),$G(QTYHLD)'=$G(PSOQX("QTY")) N DIR W !!!,"Quantity has been changed from "_QTYHLD_" to "_PSOQX("QTY") W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W ! K DIR
- 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
- ;
- UPPER(PSOSCUP) ;
- Q $TR(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- PSOSIG ;BIR/RTR-Utility to create SIG ;6/04/00
- +1 ;;7.0;OUTPATIENT PHARMACY;**46,99,114**;DEC 1997
- +2 ;External reference to PS(51 supported by DBIA 2224
- +3 ;External reference to PS(51.1 supported by DBIA 2225
- +4 ;External reference to PSDRUG( supported by DBIA 221
- +5 ;
- 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 NEW PSOSCUP
- SET SCH=$$UPPER(SCH)
- +6 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
- +7 IF SQFLAG
- QUIT
- +8 IF $PIECE($GET(^PS(51,"A",SCH)),"^")'=""
- SET SCHEX=$PIECE(^(SCH),"^")
- QUIT
- +9 SET SCLOOP=0
- FOR SCLP=1:1:$LENGTH(SCH)
- SET SCLPS=$EXTRACT(SCH,SCLP)
- IF SCLPS=" "
- SET SCLOOP=SCLOOP+1
- +10 IF SCLOOP=0
- SET SCHEX=SCH
- QUIT
- +11 SET SCLOOP=SCLOOP+1
- +12 KILL SCLHOLD
- FOR SCIN=1:1:SCLOOP
- SET (SODL,SCLHOLD(SCIN))=$PIECE(SCH," ",SCIN)
- Begin DoDot:1
- +13 IF $GET(SODL)=""
- QUIT
- +14 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
- +15 IF $GET(SQFLAG)
- QUIT
- +16 IF $PIECE($GET(^PS(51,"A",SODL)),"^")'=""
- SET SCLHOLD(SCIN)=$PIECE(^(SODL),"^")
- End DoDot:1
- +17 SET SCHEX=""
- SET SQFLAG=0
- FOR SST=1:1:SCLOOP
- SET SCHEX=SCHEX_$SELECT($GET(SQFLAG):" ",1:"")_$GET(SCLHOLD(SST))
- SET SQFLAG=1
- +18 QUIT
- QTY(PSOQX) ;
- +1 NEW QDOSE
- +2 KILL PSOQX("QTY")
- +3 NEW PSOQTYQT,PSOLPSD
- IF $GET(PSOFDR)
- SET PSOQTYQT=0
- Begin DoDot:1
- +4 IF $GET(PSODRUG("IEN"))
- IF $DATA(^PSDRUG(+$GET(PSODRUG("IEN")),0))
- Begin DoDot:2
- +5 IF $PIECE(^PSDRUG(PSODRUG("IEN"),0),"^",3)[2!($PIECE(^(0),"^",3)[3)!($PIECE(^(0),"^",3)[4)!($PIECE(^(0),"^",3)[5)
- SET PSOQTYQT=1
- End DoDot:2
- IF PSOQTYQT
- QUIT
- +6 SET PSOLPSD=""
- FOR
- SET PSOLPSD=$ORDER(PSONEW("SCHEDULE",PSOLPSD))
- IF PSOLPSD=""!(PSOQTYQT)
- QUIT
- IF $GET(PSONEW("SCHEDULE",PSOLPSD))["PRN"!($GET(PSONEW("SCHEDULE",PSOLPSD))["prn")
- SET PSOQTYQT=1
- QUIT
- End DoDot:1
- IF $GET(PSOQTYQT)
- QUIT
- +7 NEW PSOOUTQT
- SET PSOOUTQT=1
- 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
- +1 NEW PSOQEXC,PSOQAND,PSOQTHEN,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 SET (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND,PSOQTHEN,PSOQEXC)=0
- +8 FOR PSQL=1:1:QDOSE
- IF $GET(PSOQX("CONJUNCTION",PSQL))["A"
- SET PSOQAND=1
- IF $GET(PSOQX("CONJUNCTION",PSQL))["T"
- SET PSOQTHEN=1
- IF $GET(PSOQX("CONJUNCTION",PSQL))["X"
- SET PSOQEXC=1
- +9 IF $GET(PSOQEXC)
- GOTO QEND
- +10 IF $GET(PSOQAND)
- GOTO COMP^PSOSIGCX
- +11 FOR PSQ1=1:1:QDOSE
- Begin DoDot:1
- +12 IF '$GET(PSOQX("DURATION",PSQ1))
- SET PSODUMIS=PSODUMIS+1
- SET PSODUREP=PSQ1
- QUIT
- +13 SET PSODUX=$LENGTH(PSOQX("DURATION",PSQ1))
- +14 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)
- +15 SET PSODUTOT=PSODUTOT+(PSODUXX*(+$GET(PSOQX("DURATION",PSQ1))))
- End DoDot:1
- IF PSODUMIS>1
- QUIT
- +16 ; More than 1 sequence missing a duration
- IF PSODUMIS>1
- GOTO QEND
- +17 ; missing 1 duration, no days supply
- IF $GET(PSODUMIS)
- IF '$GET(PSOQX("DAYS SUPPLY"))
- GOTO QEND
- +18 SET PSODSMIN=1440*+$GET(PSOQX("DAYS SUPPLY"))
- +19 IF $GET(PSODSMIN)
- IF $GET(PSODSMIN)<$GET(PSODUTOT)
- GOTO QEND
- +20 ; no missing durations, but total durations are greater than days supply
- IF '$GET(PSODUMIS)
- IF $GET(PSODSMIN)
- IF $GET(PSODUTOT)>$GET(PSODSMIN)
- GOTO QEND
- +21 ; 1 missing duration, and total of other durations are not less than days supply
- IF $GET(PSODUMIS)
- IF $GET(PSODSMIN)
- IF $GET(PSODSMIN)'>$GET(PSODUTOT)
- GOTO QEND
- +22 ; no days supply, missing a duration
- IF '$GET(PSODSMIN)
- IF $GET(PSODUMIS)
- GOTO QEND
- +23 IF $GET(PSODUREP)
- SET PSODUDIF=$GET(PSODSMIN)-$GET(PSODUTOT)
- +24 FOR PSQ=1:1:QDOSE
- Begin DoDot:1
- +25 IF '$GET(PSOQX("DOSE ORDERED",PSQ))!($GET(PSOQX("SCHEDULE",PSQ))="")
- SET PSQQUIT=1
- QUIT
- +26 SET QTSH=$GET(PSOQX("SCHEDULE",PSQ))
- DO QTS
- IF '$GET(PSOFRQ)
- SET PSQQUIT=1
- IF $GET(PSQQUIT)
- QUIT
- +27 IF $GET(PSOQX("DURATION",PSQ))
- SET PSQMNL=$LENGTH(PSOQX("DURATION",PSQ))
- Begin DoDot:2
- +28 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)
- +29 SET PSQMIN=PSQMNLX*(+$GET(PSOQX("DURATION",PSQ)))
- End DoDot:2
- +30 IF '$GET(PSOQX("DURATION",PSQ))
- SET PSQMIN=$GET(PSODUDIF)
- +31 SET PSQMINZ=PSQMIN/PSOFRQ
- +32 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
- +33 IF $GET(PSQQUIT)
- GOTO QEND
- +34 IF $GET(PSOQRND)
- DO ROUND
- +35 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 IF $GET(PSOOUTQT)
- IF $GET(QTYHLD)
- IF $GET(PSOQX("QTY"))
- IF $GET(QTYHLD)'=$GET(PSOQX("QTY"))
- NEW DIR
- WRITE !!!,"Quantity has been changed from "_QTYHLD_" to "_PSOQX("QTY")
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- WRITE !
- KILL DIR
- +3 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
- +5 ;
- UPPER(PSOSCUP) ;
- +1 QUIT $TRANSLATE(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
