APSP61P.m

APSP61P ;IHS/DSD/ENM - PRE VERSION 6 CONV RTN  [ 09/03/97   1:30 PM ]

 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 ;ORIGINAL VA ROUTINE = PSOPATCH

 ;BHAM ISC/SAB

 ;; 5.6;Outpatient Pharmacy;**60,61**;ORIGINALLY FROM V5.6 PATCHES

 ;Rx File 52, New Person File 200 pre-version check rtn

 S ZTRTN="EN^APSP61P",ZTIO="",ZTDTH=$H,ZTDESC="Outpatient pharmacy patch version 5.6 number 60" D ^%ZTLOAD

ZZE W !!,"Pre-version 6.0 conversion routine has been queued !!",!!,"Check your mailbox in a while for a conversion notice!",!

 Q

EN S RX=0 F  S RX=$O(^PSRX(RX)) Q:'RX  I $G(^PSRX(RX,0))]"",$P(^(0),"^",2),$G(^(2)) S PRV=+$P(^PSRX(RX,0),"^",4) S:'$G(^DIC(16,PRV,"A3"))!('PRV) RX(RX)=RX_"^"_$S($G(^DIC(16,PRV,0)):$P(^(0),"^"),1:"UNKNOWN")

 I $O(RX(0)) D

 .S RXR=4,(RX,REC)=0 F  S RX=$O(RX(RX)) Q:'RX  S RXR=RXR+1,^TMP($J,"TRANS",RXR,0)="RX: "_$P(^PSRX(RX,0),"^")_"   Provider: "_$P(RX(RX),"^",2) I RXR=180 D TM K ^TMP($J,"TRANS") S RXR=3

 .I RXR>4 D TM

 E  S ^TMP($J,"TRANS",1,0)=" ",^TMP($J,"TRANS",2,0)="All pointer values are convertible !!  All is well in file #52." D TM1

EX K XMDUZ,PSOPSTF,RXR,REC,^TMP($J),RXQ,RX,DRG,NPD,RXN,IFN,EXDT,DFN,RX,PRV,HLD,NPRV S:$D(ZTQUEUED) ZTREQ="@" K ZTSK

 S ^DD(59,0,"VR")="5.6/60"

 Q

TM S ^TMP($J,"TRANS",1,0)="Following is a list of prescriptions found that could have invalid providers."

 S ^TMP($J,"TRANS",2,0)="Please edit these prescriptions using 'Edit Prescription' option located under the RX (Prescription) Menu.",^TMP($J,"TRANS",3,0)="The 'A3' node in file #16 (person) may also be invalid or non-existent."

 S ^TMP($J,"TRANS",4,0)=" "

TM1 ;S HLD=0  F  S HLD=$O(^XUSEC("XUPROG",HLD)) Q:'HLD  S XMY(HLD)=""

 S XMSUB="Prescriptions with bad provider pointers",XMDUZ=.5,XMY(DUZ)="",XMY(DUZ,1)="I",XMTEXT="^TMP($J,""TRANS""," D ^XMD

 Q

APSP61P   ;IHS/DSD/ENM - PRE VERSION 6 CONV RTN  [ 09/03/97   1:30 PM ]

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 +2       ;ORIGINAL VA ROUTINE = PSOPATCH

 +3       ;BHAM ISC/SAB

 +4       ;; 5.6;Outpatient Pharmacy;**60,61**;ORIGINALLY FROM V5.6 PATCHES

 +5       ;Rx File 52, New Person File 200 pre-version check rtn

 +6        SET ZTRTN="EN^APSP61P"

           SET ZTIO=""

           SET ZTDTH=$HOROLOG

           SET ZTDESC="Outpatient pharmacy patch version 5.6 number 60"

           DO ^%ZTLOAD

ZZE        WRITE !!,"Pre-version 6.0 conversion routine has been queued !!",!!,"Check your mailbox in a while for a conversion notice!",!

 +1        QUIT 

EN         SET RX=0

           FOR 

               SET RX=$ORDER(^PSRX(RX))

               IF 'RX

                   QUIT 

               IF $GET(^PSRX(RX,0))]""

                   IF $PIECE(^(0),"^",2)

                       IF $GET(^(2))

                           SET PRV=+$PIECE(^PSRX(RX,0),"^",4)

                           IF '$GET(^DIC(16,PRV,"A3"))!('PRV)

                               SET RX(RX)=RX_"^"_$SELECT($GET(^DIC(16,PRV,0)):$PIECE(^(0),"^"),1:"UNKNOWN")

 +1        IF $ORDER(RX(0))

               Begin DoDot:1

 +2                SET RXR=4

                   SET (RX,REC)=0

                   FOR 

                       SET RX=$ORDER(RX(RX))

                       IF 'RX

                           QUIT 

                       SET RXR=RXR+1

                       SET ^TMP($JOB,"TRANS",RXR,0)="RX: "_$PIECE(^PSRX(RX,0),"^")_"   Provider: "_$PIECE(RX(RX),"^",2)

                       IF RXR=180

                           DO TM

                           KILL ^TMP($JOB,"TRANS")

                           SET RXR=3

 +3                IF RXR>4

                       DO TM

               End DoDot:1

 +4       IF '$TEST

               SET ^TMP($JOB,"TRANS",1,0)=" "

               SET ^TMP($JOB,"TRANS",2,0)="All pointer values are convertible !!  All is well in file #52."

               DO TM1

EX         KILL XMDUZ,PSOPSTF,RXR,REC,^TMP($JOB),RXQ,RX,DRG,NPD,RXN,IFN,EXDT,DFN,RX,PRV,HLD,NPRV

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           KILL ZTSK

 +1        SET ^DD(59,0,"VR")="5.6/60"

 +2        QUIT 

TM         SET ^TMP($JOB,"TRANS",1,0)="Following is a list of prescriptions found that could have invalid providers."

 +1        SET ^TMP($JOB,"TRANS",2,0)="Please edit these prescriptions using 'Edit Prescription' option located under the RX (Prescription) Menu."

           SET ^TMP($JOB,"TRANS",3,0)="The 'A3' node in file #16 (person) may also be invalid or non-existent."

 +2        SET ^TMP($JOB,"TRANS",4,0)=" "

TM1       ;S HLD=0  F  S HLD=$O(^XUSEC("XUPROG",HLD)) Q:'HLD  S XMY(HLD)=""

 +1        SET XMSUB="Prescriptions with bad provider pointers"

           SET XMDUZ=.5

           SET XMY(DUZ)=""

           SET XMY(DUZ,1)="I"

           SET XMTEXT="^TMP($J,""TRANS"","

           DO ^XMD

 +2        QUIT