Routine: PSORN52A

PSORN52A ;IHS/DSD/JCM/SAB/FLS-Break up of PSORN52 ;06-Nov-2013 08:45;DU

 ;;7.0;OUTPATIENT PHARMACY;**157,148,268,225,306,1015,1017**;DEC 1997;Build 40

 ;Modified - IHS/MSC/PLS - 05/13/2010 -  Line FILE+26, FILE+41 and KILLOCM EP

 Q  ; Call from tag

IBHLD ;

 I $P(PSOIBHLD,"^",2)="" S $P(PSOIBHLD,"^",2)=$S($P(PSOLDIBQ,"^",2)=1:1,$P(PSOLDIBQ,"^",2)=0:0,1:"")

 I $P(PSOIBHLD,"^",3)="" S $P(PSOIBHLD,"^",3)=$S($P(PSOLDIBQ,"^",3)=1:1,$P(PSOLDIBQ,"^",3)=0:0,1:"")

 I $P(PSOIBHLD,"^",4)="" S $P(PSOIBHLD,"^",4)=$S($P(PSOLDIBQ,"^",4)=1:1,$P(PSOLDIBQ,"^",4)=0:0,1:"")

 I $P(PSOIBHLD,"^",5)="" S $P(PSOIBHLD,"^",5)=$S($P(PSOLDIBQ,"^",5)=1:1,$P(PSOLDIBQ,"^",5)=0:0,1:"")

 I $P(PSOIBHLD,"^",6)="" S $P(PSOIBHLD,"^",6)=$S($P(PSOLDIBQ,"^",6)=1:1,$P(PSOLDIBQ,"^",6)=0:0,1:"")

 I $P(PSOIBHLD,"^",7)="" S $P(PSOIBHLD,"^",7)=$S($P(PSOLDIBQ,"^",7)=1:1,$P(PSOLDIBQ,"^",7)=0:0,1:"")

 I $P(PSOIBHLD,"^",8)="" S $P(PSOIBHLD,"^",8)=$S($P(PSOLDIBQ,"^",8)=1:1,$P(PSOLDIBQ,"^",8)=0:0,1:"")

FILE ; - Filling ^PSRX and ^PS(55 entries

 S PSOX("NRX0")=PSORENW("RX0"),PSOX("NRX2")=PSORENW("RX2"),PSOX("NRX3")=PSORENW("RX3"),$P(PSOX("NRX3"),"^",5)=""

 S $P(PSOX("NRX0"),"^")=PSOX("NRX #") S:$G(PSOX("PROVIDER"))]"" $P(PSOX("NRX0"),"^",4)=PSOX("PROVIDER")

 I $G(PSORNSPD),$G(PSOX("PATIENT STATUS")),$G(PSOX("PATIENT STATUS"))?.N S $P(PSOX("NRX0"),"^",3)=PSOX("PATIENT STATUS")

 S:$G(PSOX("COSIGNING PROVIDER"))]"" $P(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER")

 S $P(PSOX("NRX0"),"^",5)=PSOX("CLINIC"),$P(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS")

 I $G(PSOX("DAYS SUPPLY")) S $P(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY")

 I $G(PSOX("QTY")) S $P(PSOX("NRX0"),"^",7)=PSOX("QTY")

 S $P(PSOX("NRX0"),"^",11)=$S(PSOX("FILL DATE")>DT&($P(PSOPAR,"^",6)):"M",$D(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$P(PSOX("NRX0"),"^",11))

 S $P(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE"),$P(PSOX("STA"),"^")=PSOX("STATUS"),$P(PSOX("NRX0"),"^",16)=$S($G(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ)

 S $P(PSOX("NRX0"),"^",17)=$G(PSODRUG("COST"))

 S $P(PSOX("NRX2"),"^")=PSOX("LOGIN DATE"),$P(PSOX("NRX2"),"^",2)=PSOX("FILL DATE"),$P(PSOX("NRX2"),"^",3)="",$P(PSOX("NRX2"),"^",4)="",$P(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE")

 S $P(PSOX("NRX2"),"^",6)=PSOX("STOP DATE")

 ;IHS/MSC/MGH Patch 1017

 S $P(PSOX("NRX2"),"^",7)=$S($G(PSOX("NDC"))]"":PSOX("NDC"),1:$G(PSODRUG("NDC")))

 S PSOX("RXNORM")=$$RXNORM^APSPFNC1($P(PSOX("NRX2"),"^",7))

 S $P(PSOX("NRX2"),"^",8)=$S($G(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$G(PSODRUG("MANUFACTURER")))

 S $P(PSOX("NRX2"),"^",9)=+PSOSITE,$P(PSOX("NRX2"),"^",10)=""

 S $P(PSOX("NRX2"),"^",11)=$S($G(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$G(PSODRUG("EXPIRATION DATE")))

 S:$G(PSOX("GENERIC PROVIDER"))]"" $P(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER")

 S $P(PSOX("NRX2"),"^",13)="",$P(PSOX("NRX2"),"^",15)="",$P(PSOX("NRX3"),"^",4)=$P(PSOX("NRX3"),"^")

 S $P(PSOX("EPH"),"^")=$S($G(PSOX("DAW"))]"":PSOX("DAW"),1:$G(PSODRUG("DAW")))

 ;S PSOX("LAST DISPENSED DATE")=$P(PSOX("NRX3"),"^")

 S PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE")

 S $P(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE")

 S:$G(PSOX("NEXT POSSIBLE REFILL"))]"" $P(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL")

 S:'$P(^VA(200,$P(PSOX("NRX0"),"^",4),"PS"),"^",7) $P(PSOX("NRX3"),"^",3)=""

 S:$G(PSOX("REMARKS"))']"" PSOX("REMARKS")="RENEWED FROM RX # "_$P(PSOX("RX0"),"^")

 S $P(PSOX("NRX3"),"^",7)=PSOX("REMARKS"),$P(PSOX("NRX3"),"^",8)=""

 ; IHS/CIA/PLS - 01/07/04 - Add Lot #, AWP, BST, INSURER, DUR and TRIP values

 S $P(PSOX("NRX2"),"^",4)=""

 S:$G(APSPMAN)=1 $P(PSOX("NRX2"),"^",4)=$S($G(PSODRUG("LOT #"))]"":PSODRUG("LOT #"),1:"")   ; Default

 I $G(PSOX("LOT #"))]"" S $P(PSOX("NRX2"),"^",4)=PSOX("LOT #")

 S $P(PSOX("NRX9999999"),"^",6)=$S($D(PSOX("AWP")):PSOX("AWP"),1:$G(PSODRUG("AWP")))

 S $P(PSOX("NRX9999999"),"^",7)=$S($D(PSOX("BST")):PSOX("BST"),1:$G(PSOBILST))

 S:$D(PSOX("INSURER")) $P(PSOX("NRX9999999"),"^",12)=PSOX("INSURER")

 S:$D(PSOX("DUR")) $P(PSOX("NRX9999999"),"^",12)=PSOX("DUR")

 S:$G(PSOX("TRIP"))]"" $P(PSOX("NRX9999999"),"^",14)=PSOX("TRIP")

 ; - File OTHER PATIENT INSTRUCTIONS into ^PSRX

 I $G(PSOFXRNX) S PSOFXRN=1

 D ^PSORN52C,FILE^PSORN52D

 I $G(^PSRX(PSOX("OIRXN"),"INSS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=^PSRX(PSOX("OIRXN"),"INSS") K PSOX1 G F55

 I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")

 ; IHS/CIA/PLS - 01/07/04 - Chronic Med Set

 ;               03/30/05 - Updated logic

 N DIE,DA,DR

 ; IHS/CIA/PLS - 03/30/05 - Changed array name for CM

 ;I $G(PSOX("ZCM"))="Y" S DIE=52,DA=PSOX("IRXN"),DR="9999999.02///Y" D ^DIE

 I $D(PSOX("CM")) S DIE=52,DA=PSOX("IRXN"),DR="9999999.02///"_$G(PSOX("CM")) D ^DIE

 ;IHS/CIA/PLS - 10/26/05 - Commented out next line and added the line after.

 ;K ^PS(55,PSODFN,"P","CP",PSOX("OIRXN"))

 D KILLOCM(+PSOX("OIRXN"))

 K PSOX1

 ; - File data into ^PS(55)

F55 L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"

 F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))

 S PSOX("55 IEN")=PSOX1

 S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)

 S ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))=""

 L -^PS(55,PSODFN,"P")

 K PSOX1

 ; - Patient Counseling questions

 I $G(OR0) D FULL^VALM1,COUN^PSONEW S PSONOOR=""

 I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR

 ; - Re-indexing file 52 entry

 K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK

 S DA=PSOX("IRXN") D ORC^PSORN52C

 ; Remove Chronic Med flag for discontinued meds

 ; FileMan will clean up the xref in ^PS(55,PSDFN,"P","CP",DA)

KILLOCM(DA) ;EP - See above two lines for description

 N DIE,DR

 S DIE=52,DR="9999999.02///N" D ^DIE  ;IHS/MSC/PLS - 01/25/10 - Changed from @ to N because of change to required field.

PSORN52A  ;IHS/DSD/JCM/SAB/FLS-Break up of PSORN52 ;06-Nov-2013 08:45;DU

 +1       ;;7.0;OUTPATIENT PHARMACY;**157,148,268,225,306,1015,1017**;DEC 1997;Build 40

 +2       ;Modified - IHS/MSC/PLS - 05/13/2010 -  Line FILE+26, FILE+41 and KILLOCM EP

 +3       ; Call from tag

           QUIT

 +4       ;

IBHLD     ;

 +1        IF $PIECE(PSOIBHLD,"^",2)=""

               SET $PIECE(PSOIBHLD,"^",2)=$SELECT($PIECE(PSOLDIBQ,"^",2)=1:1,$PIECE(PSOLDIBQ,"^",2)=0:0,1:"")

 +2        IF $PIECE(PSOIBHLD,"^",3)=""

               SET $PIECE(PSOIBHLD,"^",3)=$SELECT($PIECE(PSOLDIBQ,"^",3)=1:1,$PIECE(PSOLDIBQ,"^",3)=0:0,1:"")

 +3        IF $PIECE(PSOIBHLD,"^",4)=""

               SET $PIECE(PSOIBHLD,"^",4)=$SELECT($PIECE(PSOLDIBQ,"^",4)=1:1,$PIECE(PSOLDIBQ,"^",4)=0:0,1:"")

 +4        IF $PIECE(PSOIBHLD,"^",5)=""

               SET $PIECE(PSOIBHLD,"^",5)=$SELECT($PIECE(PSOLDIBQ,"^",5)=1:1,$PIECE(PSOLDIBQ,"^",5)=0:0,1:"")

 +5        IF $PIECE(PSOIBHLD,"^",6)=""

               SET $PIECE(PSOIBHLD,"^",6)=$SELECT($PIECE(PSOLDIBQ,"^",6)=1:1,$PIECE(PSOLDIBQ,"^",6)=0:0,1:"")

 +6        IF $PIECE(PSOIBHLD,"^",7)=""

               SET $PIECE(PSOIBHLD,"^",7)=$SELECT($PIECE(PSOLDIBQ,"^",7)=1:1,$PIECE(PSOLDIBQ,"^",7)=0:0,1:"")

 +7        IF $PIECE(PSOIBHLD,"^",8)=""

               SET $PIECE(PSOIBHLD,"^",8)=$SELECT($PIECE(PSOLDIBQ,"^",8)=1:1,$PIECE(PSOLDIBQ,"^",8)=0:0,1:"")

 +8        QUIT

 +9       ;

FILE      ; - Filling ^PSRX and ^PS(55 entries

 +1        SET PSOX("NRX0")=PSORENW("RX0")

           SET PSOX("NRX2")=PSORENW("RX2")

           SET PSOX("NRX3")=PSORENW("RX3")

           SET $PIECE(PSOX("NRX3"),"^",5)=""

 +2        SET $PIECE(PSOX("NRX0"),"^")=PSOX("NRX #")

           IF $GET(PSOX("PROVIDER"))]""

               SET $PIECE(PSOX("NRX0"),"^",4)=PSOX("PROVIDER")

 +3        IF $GET(PSORNSPD)

               IF $GET(PSOX("PATIENT STATUS"))

                   IF $GET(PSOX("PATIENT STATUS"))?.N

                       SET $PIECE(PSOX("NRX0"),"^",3)=PSOX("PATIENT STATUS")

 +4        IF $GET(PSOX("COSIGNING PROVIDER"))]""

               SET $PIECE(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER")

 +5        SET $PIECE(PSOX("NRX0"),"^",5)=PSOX("CLINIC")

           SET $PIECE(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS")

 +6        IF $GET(PSOX("DAYS SUPPLY"))

               SET $PIECE(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY")

 +7        IF $GET(PSOX("QTY"))

               SET $PIECE(PSOX("NRX0"),"^",7)=PSOX("QTY")

 +8        SET $PIECE(PSOX("NRX0"),"^",11)=$SELECT(PSOX("FILL DATE")>DT&($PIECE(PSOPAR,"^",6)):"M",$DATA(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$PIECE(PSOX("NRX0"),"^",11))

 +9        SET $PIECE(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE")

           SET $PIECE(PSOX("STA"),"^")=PSOX("STATUS")

           SET $PIECE(PSOX("NRX0"),"^",16)=$SELECT($GET(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ)

 +10       SET $PIECE(PSOX("NRX0"),"^",17)=$GET(PSODRUG("COST"))

 +11       SET $PIECE(PSOX("NRX2"),"^")=PSOX("LOGIN DATE")

           SET $PIECE(PSOX("NRX2"),"^",2)=PSOX("FILL DATE")

           SET $PIECE(PSOX("NRX2"),"^",3)=""

           SET $PIECE(PSOX("NRX2"),"^",4)=""

           SET $PIECE(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE")

 +12       SET $PIECE(PSOX("NRX2"),"^",6)=PSOX("STOP DATE")

 +13      ;IHS/MSC/MGH Patch 1017

 +14       SET $PIECE(PSOX("NRX2"),"^",7)=$SELECT($GET(PSOX("NDC"))]"":PSOX("NDC"),1:$GET(PSODRUG("NDC")))

 +15       SET PSOX("RXNORM")=$$RXNORM^APSPFNC1($PIECE(PSOX("NRX2"),"^",7))

 +16       SET $PIECE(PSOX("NRX2"),"^",8)=$SELECT($GET(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$GET(PSODRUG("MANUFACTURER")))

 +17       SET $PIECE(PSOX("NRX2"),"^",9)=+PSOSITE

           SET $PIECE(PSOX("NRX2"),"^",10)=""

 +18       SET $PIECE(PSOX("NRX2"),"^",11)=$SELECT($GET(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$GET(PSODRUG("EXPIRATION DATE")))

 +19       IF $GET(PSOX("GENERIC PROVIDER"))]""

               SET $PIECE(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER")

 +20       SET $PIECE(PSOX("NRX2"),"^",13)=""

           SET $PIECE(PSOX("NRX2"),"^",15)=""

           SET $PIECE(PSOX("NRX3"),"^",4)=$PIECE(PSOX("NRX3"),"^")

 +21       SET $PIECE(PSOX("EPH"),"^")=$SELECT($GET(PSOX("DAW"))]"":PSOX("DAW"),1:$GET(PSODRUG("DAW")))

 +22      ;S PSOX("LAST DISPENSED DATE")=$P(PSOX("NRX3"),"^")

 +23       SET PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE")

 +24       SET $PIECE(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE")

 +25       IF $GET(PSOX("NEXT POSSIBLE REFILL"))]""

               SET $PIECE(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL")

 +26       IF '$PIECE(^VA(200,$PIECE(PSOX("NRX0"),"^",4),"PS"),"^",7)

               SET $PIECE(PSOX("NRX3"),"^",3)=""

 +27       IF $GET(PSOX("REMARKS"))']""

               SET PSOX("REMARKS")="RENEWED FROM RX # "_$PIECE(PSOX("RX0"),"^")

 +28       SET $PIECE(PSOX("NRX3"),"^",7)=PSOX("REMARKS")

           SET $PIECE(PSOX("NRX3"),"^",8)=""

 +29      ; IHS/CIA/PLS - 01/07/04 - Add Lot #, AWP, BST, INSURER, DUR and TRIP values

 +30       SET $PIECE(PSOX("NRX2"),"^",4)=""

 +31      ; Default

           IF $GET(APSPMAN)=1

               SET $PIECE(PSOX("NRX2"),"^",4)=$SELECT($GET(PSODRUG("LOT #"))]"":PSODRUG("LOT #"),1:"")

 +32       IF $GET(PSOX("LOT #"))]""

               SET $PIECE(PSOX("NRX2"),"^",4)=PSOX("LOT #")

 +33       SET $PIECE(PSOX("NRX9999999"),"^",6)=$SELECT($DATA(PSOX("AWP")):PSOX("AWP"),1:$GET(PSODRUG("AWP")))

 +34       SET $PIECE(PSOX("NRX9999999"),"^",7)=$SELECT($DATA(PSOX("BST")):PSOX("BST"),1:$GET(PSOBILST))

 +35       IF $DATA(PSOX("INSURER"))

               SET $PIECE(PSOX("NRX9999999"),"^",12)=PSOX("INSURER")

 +36       IF $DATA(PSOX("DUR"))

               SET $PIECE(PSOX("NRX9999999"),"^",12)=PSOX("DUR")

 +37       IF $GET(PSOX("TRIP"))]""

               SET $PIECE(PSOX("NRX9999999"),"^",14)=PSOX("TRIP")

 +38      ;

 +39      ; - File OTHER PATIENT INSTRUCTIONS into ^PSRX

 +40       IF $GET(PSOFXRNX)

               SET PSOFXRN=1

 +41       DO ^PSORN52C

           DO FILE^PSORN52D

 +42       IF $GET(^PSRX(PSOX("OIRXN"),"INSS"))]""

               SET ^PSRX(PSOX("IRXN"),"INSS")=^PSRX(PSOX("OIRXN"),"INSS")

               KILL PSOX1

               GOTO F55

 +43       IF $GET(PSOX("SINS"))]""

               SET ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")

 +44      ; IHS/CIA/PLS - 01/07/04 - Chronic Med Set

 +45      ;               03/30/05 - Updated logic

 +46       NEW DIE,DA,DR

 +47      ; IHS/CIA/PLS - 03/30/05 - Changed array name for CM

 +48      ;I $G(PSOX("ZCM"))="Y" S DIE=52,DA=PSOX("IRXN"),DR="9999999.02///Y" D ^DIE

 +49       IF $DATA(PSOX("CM"))

               SET DIE=52

               SET DA=PSOX("IRXN")

               SET DR="9999999.02///"_$GET(PSOX("CM"))

               DO ^DIE

 +50      ;IHS/CIA/PLS - 10/26/05 - Commented out next line and added the line after.

 +51      ;K ^PS(55,PSODFN,"P","CP",PSOX("OIRXN"))

 +52       DO KILLOCM(+PSOX("OIRXN"))

 +53       KILL PSOX1

 +54      ;

 +55      ; - File data into ^PS(55)

F55        LOCK +^PS(55,PSODFN,"P"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)

           IF '$DATA(^PS(55,PSODFN,"P",0))

               SET ^(0)="^55.03PA^^"

 +1        FOR PSOX1=$PIECE(^PS(55,PSODFN,"P",0),"^",3):1

               IF '$DATA(^PS(55,PSODFN,"P",PSOX1))

                   QUIT

 +2        SET PSOX("55 IEN")=PSOX1

 +3        SET ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN")

           SET $PIECE(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($PIECE(^PS(55,PSODFN,"P",0),"^",4)+1)

 +4        SET ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))=""

 +5        LOCK -^PS(55,PSODFN,"P")

 +6        KILL PSOX1

 +7       ;

 +8       ; - Patient Counseling questions

 +9        IF $GET(OR0)

               DO FULL^VALM1

               DO COUN^PSONEW

               SET PSONOOR=""

 +10       IF $DATA(^XUSEC("PSORPH",DUZ))

               SET DA=PSOX("IRXN")

               SET DIE=52

               SET DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1"

               DO ^DIE

               KILL DIE,DR

 +11      ;

 +12      ; - Re-indexing file 52 entry

 +13       KILL DIK,DA

           SET DIK="^PSRX("

           SET DA=PSOX("IRXN")

           DO IX1^DIK

           KILL DIK

 +14       SET DA=PSOX("IRXN")

           DO ORC^PSORN52C

 +15       QUIT

 +16      ; Remove Chronic Med flag for discontinued meds

 +17      ; FileMan will clean up the xref in ^PS(55,PSDFN,"P","CP",DA)

KILLOCM(DA) ;EP - See above two lines for description

 +1        NEW DIE,DR

 +2       ;IHS/MSC/PLS - 01/25/10 - Changed from @ to N because of change to required field.

           SET DIE=52

           SET DR="9999999.02///N"

           DO ^DIE

 +3        QUIT

PSORN52A.m