PSOSIGNO ;BHAM ISC/RTR-Check new Sig for Route and Schedule ; 10/10/96
;;7.0;OUTPATIENT PHARMACY;**282**;DEC 1997;Build 18
;
;Pass in IEN from Pending File, and New Sig
;Returned PSOSIGFL=0 no new order (common Routes and Schedules)
; PSOSIGFL=1 new order (no Route to having route) or
; (no Schedule to having schedule) or
; (visa versa, or discrepency)
;
;Also returned are arrays with Original and New Routes & Schedules:
;
; PSOMDRTE array (original route) PSOMDRTE(1)="ORAL"
;
; PSONEWMD array (new routes) PSONEWMD(1)="ORAL"
; PSONEWMD(22)="BOTH EYES"
;
; PSOSCH array (original schedules) PSOSCH("Q12H")=""
; PSOSCH("Q4H")=""
;
; PSONEWSD array (new schedules) PSONEWSD("Q4H")=""
; PSONEWSD("Q8H")=""
;
EN(PSPENIEN,PSPENSIG) ;
K PSONEWMD,PSOMDRTE,PSOSCH,PSONEWSD N AA,GGG,PSONULL,XXX,XXXX,ZZZZ
;S PSOSIGFL=0
I $P($G(^PS(52.41,PSPENIEN,0)),"^",15),$P($G(^PS(51.2,+$P(^(0),"^",15),0)),"^")'="" S PSOMDRTE($P(^PS(52.41,PSPENIEN,0),"^",15))=$P(^PS(51.2,+$P(^(0),"^",15),0),"^")
F ZZZZ=0:0 S ZZZZ=$O(^PS(52.41,PSPENIEN,1,ZZZZ)) Q:'ZZZZ I $P($G(^PS(52.41,PSPENIEN,1,ZZZZ,1)),"^")'="" S PSOSCH($P(^(1),"^"))=""
F GGG=1:1:$L(PSPENSIG," ") S XXX=$P(PSPENSIG," ",GGG) D:XXX]""
.I $D(^PS(51,"A",XXX)) D
..;PSO*7*282 intended use
..S XXXX=$O(^PS(51,"B",XXX,0)) D:XXXX&($P($G(^PS(51,XXXX,0)),"^",4)>1)
...I $P($G(^PS(51,XXXX,0)),"^",5),$P($G(^PS(51.2,+$P(^(0),"^",5),0)),"^")'="" S PSONEWMD($P(^PS(51,XXXX,0),"^",5))=$P(^PS(51.2,$P(^(0),"^",5),0),"^")
...I $P($G(^PS(51,XXXX,0)),"^",6)'="" S PSONEWSD($P(^(0),"^",6))=""
NEW ;Check for new order
S PSONULL=""
I $O(PSOMDRTE(0)),'$O(PSONEWMD(0)) S PSOSIGFL=1
Q:$G(PSOSIGFL) I $O(PSONEWMD(0)),'$O(PSOMDRTE(0)) S PSOSIGFL=1
Q:$G(PSOSIGFL) I $O(PSOSCH(PSONULL))="",$O(PSONEWSD(PSONULL))'="" S PSOSIGFL=1
Q:$G(PSOSIGFL) I $O(PSONEWSD(PSONULL))="",$O(PSOSCH(PSONULL))'="" S PSOSIGFL=1
Q:$G(PSOSIGFL)
ERROR ;check for error
;This is also a new order now
F AA=0:0 S AA=$O(PSOMDRTE(AA)) Q:'AA!($G(PSOSIGFL)) I '$D(PSONEWMD(AA)) S PSOSIGFL=1
Q:$G(PSOSIGFL) F AA=0:0 S AA=$O(PSONEWMD(AA)) Q:'AA!($G(PSOSIGFL)) I '$D(PSOMDRTE(AA)) S PSOSIGFL=1
Q:$G(PSOSIGFL) S AA="" F S AA=$O(PSOSCH(AA)) Q:AA=""!($G(PSOSIGFL)) I '$D(PSONEWSD(AA)) S PSOSIGFL=1
Q:$G(PSOSIGFL) S AA="" F S AA=$O(PSONEWSD(AA)) Q:AA=""!($G(PSOSIGFL)) I '$D(PSOSCH(AA)) S PSOSIGFL=1
Q
;
EN1(PSRENIEN,PSRENSIG) ;
;Same as above, only for a new Sig from File 52
;Pass in IEN from 52, and new Sig
K PSONEWMD,PSOMDRTE,PSOSCH,PSONEWSD N AA,GGG,PSONULL,XXX,XXXX,ZZZZ
;S PSOSIGFL=0
F GGG=0:0 S GGG=$O(^PSRX(PSRENIEN,"MEDR",GGG)) Q:'GGG S ZZZZ=+$P(^(GGG,0),"^") I ZZZZ,$P($G(^PS(51.2,ZZZZ,0)),"^")'="" S PSOMDRTE(ZZZZ)=$P(^(0),"^")
F ZZZZ=0:0 S ZZZZ=$O(^PSRX(PSRENIEN,"SCH",ZZZZ)) Q:'ZZZZ I $P(^(ZZZZ,0),"^")'="" S PSOSCH($P(^(0),"^"))=""
F GGG=1:1:$L(PSRENSIG," ") S XXX=$P(PSRENSIG," ",GGG) D:XXX]""
.I $D(^PS(51,"A",XXX)) D
..;PSO*7*282 intended use
..S XXXX=$O(^PS(51,"B",XXX,0)) D:XXXX&($P($G(^PS(51,XXXX,0)),"^",4)>1)
...I $P($G(^PS(51,XXXX,0)),"^",5),$P($G(^PS(51.2,+$P(^(0),"^",5),0)),"^")'="" S PSONEWMD($P(^PS(51,XXXX,0),"^",5))=$P(^PS(51.2,$P(^(0),"^",5),0),"^")
...I $P($G(^PS(51,XXXX,0)),"^",6)'="" S PSONEWSD($P(^(0),"^",6))=""
NEWOR ;Check for new order
G NEW
;
POP(PSOPOPRX) ;Pass in Internal Rx number, will populate Med Route and
;schedule fields from BACK door Sig
N BACKSIG,BBB,LLL,LLLL,POPMD,POPSC
Q:'$D(^PSRX(PSOPOPRX,0))
Q:$P($G(^PSRX(PSOPOPRX,"SIG")),"^")=""!($P($G(^("SIG")),"^",2))
S BACKSIG=$P(^PSRX(PSOPOPRX,"SIG"),"^")
F BBB=1:1:$L(BACKSIG," ") S LLL=$P(BACKSIG," ",BBB) D:LLL]""
.I $D(^PS(51,"A",LLL)) D
..;PSO*7*282 intended use
..S LLLL=$O(^PS(51,"B",LLL,0)) D:LLLL&($P($G(^PS(51,LLLL,0)),"^",4)>1)
...I $P($G(^PS(51,LLLL,0)),"^",5),$P($G(^PS(51.2,+$P(^(0),"^",5),0)),"^")'="" S POPMD($P(^PS(51,LLLL,0),"^",5))=""
...I $P($G(^PS(51,LLLL,0)),"^",6)'="" S POPSC($P(^(0),"^",6))=""
K ^PSRX(PSOPOPRX,"MEDR"),^PSRX(PSOPOPRX,"SCH")
S LLLL=1 F LLL=0:0 S LLL=$O(POPMD(LLL)) Q:'LLL S ^PSRX(PSOPOPRX,"MEDR",LLLL,0)=LLL,^PSRX(PSOPOPRX,"MEDR",0)="^52.037PA^"_LLLL_"^"_LLLL S LLLL=LLLL+1
S LLLL=1,LLL="" F S LLL=$O(POPSC(LLL)) Q:LLL="" S ^PSRX(PSOPOPRX,"SCH",LLLL,0)=LLL,^PSRX(PSOPOPRX,"SCH",0)="^52.038A^"_LLLL_"^"_LLLL S LLLL=LLLL+1
K PSOPOPRX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSIGNO 4537 printed Apr 09, 2024@21:34:32 Page 2
PSOSIGNO ;BHAM ISC/RTR-Check new Sig for Route and Schedule ; 10/10/96
+1 ;;7.0;OUTPATIENT PHARMACY;**282**;DEC 1997;Build 18
+2 ;
+3 ;Pass in IEN from Pending File, and New Sig
+4 ;Returned PSOSIGFL=0 no new order (common Routes and Schedules)
+5 ; PSOSIGFL=1 new order (no Route to having route) or
+6 ; (no Schedule to having schedule) or
+7 ; (visa versa, or discrepency)
+8 ;
+9 ;Also returned are arrays with Original and New Routes & Schedules:
+10 ;
+11 ; PSOMDRTE array (original route) PSOMDRTE(1)="ORAL"
+12 ;
+13 ; PSONEWMD array (new routes) PSONEWMD(1)="ORAL"
+14 ; PSONEWMD(22)="BOTH EYES"
+15 ;
+16 ; PSOSCH array (original schedules) PSOSCH("Q12H")=""
+17 ; PSOSCH("Q4H")=""
+18 ;
+19 ; PSONEWSD array (new schedules) PSONEWSD("Q4H")=""
+20 ; PSONEWSD("Q8H")=""
+21 ;
EN(PSPENIEN,PSPENSIG) ;
+1 KILL PSONEWMD,PSOMDRTE,PSOSCH,PSONEWSD
NEW AA,GGG,PSONULL,XXX,XXXX,ZZZZ
+2 ;S PSOSIGFL=0
+3 IF $PIECE($GET(^PS(52.41,PSPENIEN,0)),"^",15)
IF $PIECE($GET(^PS(51.2,+$PIECE(^(0),"^",15),0)),"^")'=""
SET PSOMDRTE($PIECE(^PS(52.41,PSPENIEN,0),"^",15))=$PIECE(^PS(51.2,+$PIECE(^(0),"^",15),0),"^")
+4 FOR ZZZZ=0:0
SET ZZZZ=$ORDER(^PS(52.41,PSPENIEN,1,ZZZZ))
if 'ZZZZ
QUIT
IF $PIECE($GET(^PS(52.41,PSPENIEN,1,ZZZZ,1)),"^")'=""
SET PSOSCH($PIECE(^(1),"^"))=""
+5 FOR GGG=1:1:$LENGTH(PSPENSIG," ")
SET XXX=$PIECE(PSPENSIG," ",GGG)
if XXX]""
Begin DoDot:1
+6 IF $DATA(^PS(51,"A",XXX))
Begin DoDot:2
+7 ;PSO*7*282 intended use
+8 SET XXXX=$ORDER(^PS(51,"B",XXX,0))
if XXXX&($PIECE($GET(^PS(51,XXXX,0)),"^",4)>1)
Begin DoDot:3
+9 IF $PIECE($GET(^PS(51,XXXX,0)),"^",5)
IF $PIECE($GET(^PS(51.2,+$PIECE(^(0),"^",5),0)),"^")'=""
SET PSONEWMD($PIECE(^PS(51,XXXX,0),"^",5))=$PIECE(^PS(51.2,$PIECE(^(0),"^",5),0),"^")
+10 IF $PIECE($GET(^PS(51,XXXX,0)),"^",6)'=""
SET PSONEWSD($PIECE(^(0),"^",6))=""
End DoDot:3
End DoDot:2
End DoDot:1
NEW ;Check for new order
+1 SET PSONULL=""
+2 IF $ORDER(PSOMDRTE(0))
IF '$ORDER(PSONEWMD(0))
SET PSOSIGFL=1
+3 if $GET(PSOSIGFL)
QUIT
IF $ORDER(PSONEWMD(0))
IF '$ORDER(PSOMDRTE(0))
SET PSOSIGFL=1
+4 if $GET(PSOSIGFL)
QUIT
IF $ORDER(PSOSCH(PSONULL))=""
IF $ORDER(PSONEWSD(PSONULL))'=""
SET PSOSIGFL=1
+5 if $GET(PSOSIGFL)
QUIT
IF $ORDER(PSONEWSD(PSONULL))=""
IF $ORDER(PSOSCH(PSONULL))'=""
SET PSOSIGFL=1
+6 if $GET(PSOSIGFL)
QUIT
ERROR ;check for error
+1 ;This is also a new order now
+2 FOR AA=0:0
SET AA=$ORDER(PSOMDRTE(AA))
if 'AA!($GET(PSOSIGFL))
QUIT
IF '$DATA(PSONEWMD(AA))
SET PSOSIGFL=1
+3 if $GET(PSOSIGFL)
QUIT
FOR AA=0:0
SET AA=$ORDER(PSONEWMD(AA))
if 'AA!($GET(PSOSIGFL))
QUIT
IF '$DATA(PSOMDRTE(AA))
SET PSOSIGFL=1
+4 if $GET(PSOSIGFL)
QUIT
SET AA=""
FOR
SET AA=$ORDER(PSOSCH(AA))
if AA=""!($GET(PSOSIGFL))
QUIT
IF '$DATA(PSONEWSD(AA))
SET PSOSIGFL=1
+5 if $GET(PSOSIGFL)
QUIT
SET AA=""
FOR
SET AA=$ORDER(PSONEWSD(AA))
if AA=""!($GET(PSOSIGFL))
QUIT
IF '$DATA(PSOSCH(AA))
SET PSOSIGFL=1
+6 QUIT
+7 ;
EN1(PSRENIEN,PSRENSIG) ;
+1 ;Same as above, only for a new Sig from File 52
+2 ;Pass in IEN from 52, and new Sig
+3 KILL PSONEWMD,PSOMDRTE,PSOSCH,PSONEWSD
NEW AA,GGG,PSONULL,XXX,XXXX,ZZZZ
+4 ;S PSOSIGFL=0
+5 FOR GGG=0:0
SET GGG=$ORDER(^PSRX(PSRENIEN,"MEDR",GGG))
if 'GGG
QUIT
SET ZZZZ=+$PIECE(^(GGG,0),"^")
IF ZZZZ
IF $PIECE($GET(^PS(51.2,ZZZZ,0)),"^")'=""
SET PSOMDRTE(ZZZZ)=$PIECE(^(0),"^")
+6 FOR ZZZZ=0:0
SET ZZZZ=$ORDER(^PSRX(PSRENIEN,"SCH",ZZZZ))
if 'ZZZZ
QUIT
IF $PIECE(^(ZZZZ,0),"^")'=""
SET PSOSCH($PIECE(^(0),"^"))=""
+7 FOR GGG=1:1:$LENGTH(PSRENSIG," ")
SET XXX=$PIECE(PSRENSIG," ",GGG)
if XXX]""
Begin DoDot:1
+8 IF $DATA(^PS(51,"A",XXX))
Begin DoDot:2
+9 ;PSO*7*282 intended use
+10 SET XXXX=$ORDER(^PS(51,"B",XXX,0))
if XXXX&($PIECE($GET(^PS(51,XXXX,0)),"^",4)>1)
Begin DoDot:3
+11 IF $PIECE($GET(^PS(51,XXXX,0)),"^",5)
IF $PIECE($GET(^PS(51.2,+$PIECE(^(0),"^",5),0)),"^")'=""
SET PSONEWMD($PIECE(^PS(51,XXXX,0),"^",5))=$PIECE(^PS(51.2,$PIECE(^(0),"^",5),0),"^")
+12 IF $PIECE($GET(^PS(51,XXXX,0)),"^",6)'=""
SET PSONEWSD($PIECE(^(0),"^",6))=""
End DoDot:3
End DoDot:2
End DoDot:1
NEWOR ;Check for new order
+1 GOTO NEW
+2 ;
POP(PSOPOPRX) ;Pass in Internal Rx number, will populate Med Route and
+1 ;schedule fields from BACK door Sig
+2 NEW BACKSIG,BBB,LLL,LLLL,POPMD,POPSC
+3 if '$DATA(^PSRX(PSOPOPRX,0))
QUIT
+4 if $PIECE($GET(^PSRX(PSOPOPRX,"SIG")),"^")=""!($PIECE($GET(^("SIG")),"^",2))
QUIT
+5 SET BACKSIG=$PIECE(^PSRX(PSOPOPRX,"SIG"),"^")
+6 FOR BBB=1:1:$LENGTH(BACKSIG," ")
SET LLL=$PIECE(BACKSIG," ",BBB)
if LLL]""
Begin DoDot:1
+7 IF $DATA(^PS(51,"A",LLL))
Begin DoDot:2
+8 ;PSO*7*282 intended use
+9 SET LLLL=$ORDER(^PS(51,"B",LLL,0))
if LLLL&($PIECE($GET(^PS(51,LLLL,0)),"^",4)>1)
Begin DoDot:3
+10 IF $PIECE($GET(^PS(51,LLLL,0)),"^",5)
IF $PIECE($GET(^PS(51.2,+$PIECE(^(0),"^",5),0)),"^")'=""
SET POPMD($PIECE(^PS(51,LLLL,0),"^",5))=""
+11 IF $PIECE($GET(^PS(51,LLLL,0)),"^",6)'=""
SET POPSC($PIECE(^(0),"^",6))=""
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL ^PSRX(PSOPOPRX,"MEDR"),^PSRX(PSOPOPRX,"SCH")
+13 SET LLLL=1
FOR LLL=0:0
SET LLL=$ORDER(POPMD(LLL))
if 'LLL
QUIT
SET ^PSRX(PSOPOPRX,"MEDR",LLLL,0)=LLL
SET ^PSRX(PSOPOPRX,"MEDR",0)="^52.037PA^"_LLLL_"^"_LLLL
SET LLLL=LLLL+1
+14 SET LLLL=1
SET LLL=""
FOR
SET LLL=$ORDER(POPSC(LLL))
if LLL=""
QUIT
SET ^PSRX(PSOPOPRX,"SCH",LLLL,0)=LLL
SET ^PSRX(PSOPOPRX,"SCH",0)="^52.038A^"_LLLL_"^"_LLLL
SET LLLL=LLLL+1
+15 KILL PSOPOPRX
+16 QUIT
