- PSOSIGNO ;BHAM ISC/RTR-Check new Sig for Route and Schedule ; 10/10/96
- ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- ;
- ;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
- ..S XXXX=$O(^PS(51,"B",XXX,0)) D:XXXX
- ...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
- ..S XXXX=$O(^PS(51,"B",XXX,0)) D:XXXX
- ...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
- ..S LLLL=$O(^PS(51,"B",LLL,0)) D:LLLL
- ...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
- PSOSIGNO ;BHAM ISC/RTR-Check new Sig for Route and Schedule ; 10/10/96
- +1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- +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 SET XXXX=$ORDER(^PS(51,"B",XXX,0))
- IF XXXX
- Begin DoDot:3
- +8 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),"^")
- +9 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 SET XXXX=$ORDER(^PS(51,"B",XXX,0))
- IF XXXX
- Begin DoDot:3
- +10 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),"^")
- +11 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 SET LLLL=$ORDER(^PS(51,"B",LLL,0))
- IF LLLL
- Begin DoDot:3
- +9 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))=""
- +10 IF $PIECE($GET(^PS(51,LLLL,0)),"^",6)'=""
- SET POPSC($PIECE(^(0),"^",6))=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 KILL ^PSRX(PSOPOPRX,"MEDR"),^PSRX(PSOPOPRX,"SCH")
- +12 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
- +13 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
- +14 KILL PSOPOPRX
- +15 QUIT
