ABSPOSI1.m

ABSPOSI1 ; IHS/FCS/DRS - support for the prescrip. field on the form ;    [ 09/12/2002  10:10 AM ]

 ;;1.0;PHARMACY POINT OF SALE;**3,10,44**;JUN 21, 2001;Build 38

 ;----------------------------------------------------------------------

 ;IHS/SD/lwj 03/10/04 patch 10

 ; Routine adjusted to call ABSPFUNC to retrieve

 ; the Prescription Refill NDC value.  At some

 ; point the call needs to be modified to call APSPFUNC.

 ; See ABSPFUNC for details on why call was done.

 ;----------------------------------------------------------------------

 Q

ENABASK D THEASKS(0) Q  ; enable the "Ask preauth?" etc. questions  

DISABASK D THEASKS(1) Q  ; disable those questions

THEASKS(N)         ; don't use this directly, the 0/1 meanings are backwards 

 ; from what you would think they mean (0 enables, 1 disables)

 N PAGE,BLOCK S PAGE=1,BLOCK=1

 N F F F=12,14,16,18,20 D

 . ;I N=0,F=18 Q  ; NOT IMPLEM'D - DON'T ENABLE

 . D UNED^DDSUTL(F,BLOCK,PAGE,N)

 Q

VALID ; VALID is the Data Validation action for the field.

 ; It may invoke prescription or visit lookup.

 ; It might reset X and DDSEXT. 

 ;D MSGWAIT("We are in VALID^"_$T(+0)_" with X="_$G(X)_", DDSEXT="_$G(DDSEXT))

 N Z S Z=$$VALIDATE(X)

 ;D MSGWAIT("VALIDATE^() returns and we have Z="_Z)

 S (X,DDSEXT)=Z

 ;D MSGWAIT("On the way out, we have set X="_$G(X)_" and DDSEXT="_$G(DDSEXT))

 Q

VALIDATE(X)         ;  validate input and return transformed value 

 ; Returns -1 if error and sets DDSERROR

 ;D MSGWAIT("We are in VALIDATE^"_$T(+0)_" with X="_$G(X))

 K DDSERROR

 N TYPE ; = "RX" or "VISIT"

 ;

VAL1 I 0 ; ELSE each possibility:

 E  I X?1N.N1"-"1N.N D  ; ANMC bar code labels

 . S TYPE="RX"

 . S X="`"_$P(X,"-",2)

 . S X=$$RXLOOKUP(X,"NOX")

 . I X<0 S DDSERROR=1

 E  I X?1N.N,$P($G(^ABSP(9002313.99,1,"INPUT")),U)=0 D  ; Sitka

 . S TYPE="RX"

 . S X="`"_+X

 . S X=$$RXLOOKUP(X,"NOX")

 . I X<0 S DDSERROR=2

 E  I X?1"`"1N.N  D  ; internal RX number input ; 10/26/2000

 . S TYPE="RX",X=$$RXLOOKUP(X,"NOX") I X<0 S DDSERROR=6

VAL2 ;

 E  I X?1N.N0.1A!($$UPPER(X)?1"RX".P1N.N0.1A) D  ;external RX # input

 . S TYPE="RX"

 . I $$UPPER(X)?1"RX".E D

 . . S X=$P(X,"RX",2) F  Q:$E(X)?1N  S X=$E(X,2,$L(X))

 . S X=$$RXLOOKUP(X,"OX")

 . I X<0 S DDSERROR=5

 E  I X="" D  ; null (includes "@")

 . S X="DELETE"

 E  I $$UPPER(X)=$E("FIND",1,$L(X)) D

 . S TYPE="RX" ; might change to VISIT, below

 . ; RESET^DDS is the wrong thing to do here

 . ; try it without this, too  D FULLSCRE

 . W @IOF

 . S X=$$RXFIND^ABSPOSIF ; = RXI^RXR if presc,  = VISITIEN if visit

 . D REFRESH^DDSUTL

 . I X<0 S DDSERROR=3 Q

 . I $L(X,U)=1 S TYPE="VISIT"

 E  I X?0.1U1N.N1"."1N.N1U D  ; VCN number

 . S TYPE="VISIT" ; it might change to RX, below

 . S X=$O(^AUPNVSIT("VCN",X,0))

 . W @IOF

 . S X=$$RXFIND^ABSPOSIF(,,X) ; 

 . D REFRESH^DDSUTL

 . I 'X S DDSERROR=4,X=-1

 . I $L(X,U)=2 S TYPE="RX"

 E  I $L(X)'<3,$$UPPER(X)=$E("DELETE",1,$L(X)) D

 . S X="DELETE" ; and let EFFECTS do the dirty work later

 E  D  ; if it didn't hit any of the recognized cases:

 . S X=-1,DDSERROR=999

 ; And now deal with the results

 I X>0 D

 . I TYPE="RX" D  ; X=RXI or RXI^RXR

 . . S X="`"_X ; RXR part will be dealt with in EFFECTS

 . E  I TYPE="VISIT" D  ; X points to ^AUPNVSIT

 . . S X="V`"_X ; may be changed to VCN in EFFECTS

 E  I X?1"`"1N.N ; nothing needs to be done ; it's `RXI

 E  I X="DELETE" ; okay, nothing to do here ; EFFECTS takes care of it

 E  I X="@" ; okay, EFFECTS takes care of it

 E  I X=-1 D  ; DDSERROR should already be set.

 . D HELP^ABSPOSI1

 E  D IMPOSS^ABSPOSUE("P","TI","Unexpected case: X="_X,,"VAL2",$T(+0))

 Q X

FULLSCRE ; adapted from FULL^VALM1

 S IOTM=1,IOBM=IOSL W IOSC W @IOSTBM W IORC Q

RXLOOKUP(X,DIC0)         ; lookup by `IEN or prescrip # or patient name or whatever

 N DIC,Y,DUOUT,DTOUT S DIC="^PSRX(",DIC(0)=DIC0

 ;S ^TMP($T(+0),$J," 0 RXLOOKUP^DIC")=$H

 ;S ^TMP($T(+0),$J," 1 RXLOOKUP^DIC X^DIC0=")=$G(X)_U_$G(DIC0)

 D ^DIC

 N RET S RET=$S(Y>0:"`"_+Y,1:-1)

 I DIC0["A" D REFRESH^DDSUTL ; put screen back together

 ;S ^TMP($T(+0),$J," 2 RXLOOKUP^DIC RET=")=RET

 Q RET

HELP ;EP -

 N AR,N S N=0

 D HELP1("Scan the prescription label.")

 D HELP1("Or, you can enter ` followed by the internal number.")

 D HELP1("Or, type F or FIND to lookup by patient name.")

 D HELP1("Or, type the VCN number (non-prescription charges only).")

 I $$GET^DDSVAL(DIE,.DA,.02)]"" D HELP1("Answer with   @    to delete this line.")

 D HLP^DDSUTL(.AR)

 Q

HELP1(X) S N=N+1,AR(N)=X Q

MSGWAIT(X) ;EP - from ABSPOSI2,ABSPOSI8

 N AR S AR(1)=X

 ; ,AR(2)="$$EOP" 

 D HLP^DDSUTL(.AR)

 D HLP^DDSUTL("$$EOP")

 Q

EFFECTS N ERR ; side effects of putting a value in the prescription field

 N RX,NDC,PATNAME,DRUGNAME,FILLDATE

 N RXI,RXR,DRUG,PAT,AWPMED,VISIT,IEN59

 ; NDCDEF - not a field on the form, so this cheap fetch is okay

 N NDCDEF S NDCDEF=$P($G(^ABSP(9002313.51,DA(1),100)),U)

 I X?1"`"1N.N!(X?1"`"1N.N1"^"1N.N) D  ; It's a prescription:

 . ; Refill may or may not have been specified (FIND leads to 2nd piece)

 . I $L(X,U)>1 S RXR=$P(X,U,2),X=$P(X,U)

 . E  S RXR=$O(^PSRX($P(X,"`",2),1," "),-1)

 . S RX=X,RXI=$P(X,"`",2) ; display the `internal form

 . N R0 S R0=$G(^PSRX(RXI,0)) I R0="" D IMPOSS^ABSPOSUE("DB,P","TI","VALIDATE should have caught this",,"EFFECTS",$T(+0))

 . S PAT=$P(R0,U,2)

 . S PATNAME=$P(^DPT(PAT,0),U)

 . S DRUG=$P(R0,U,6) ; get pointer to drug file ; ABSP*1.0T7*11 ; removed "N DRUG", the NEW happened at the calling level and DRUG is needed below

 . ;OIT/CAS/RCS 10022012 - Patch 44, only allow 40 characters for the drug name, HEAT # 86226

 . I DRUG S DRUGNAME=$E($P($G(^PSDRUG(DRUG,0)),U),1,40) ; get drug name

 . E  S DRUGNAME="?missing from ^PSRX?"

 . I RXR D  ; refill

 . . S FILLDATE=$P(^PSRX(RXI,1,RXR,0),U) ;$O(^PSRX(X,1,"B",""),-1)

 . . ;IHS/SD/lwj 03/10/04 patch 10 nxt line rmkd out, new line added

 . . ;I NDCDEF S NDC=$P(^PSRX(RXI,1,RXR,0),U,13)

 . . I NDCDEF S NDC=$$NDCVAL^ABSPFUNC(RXI,RXR)  ;patch 10

 . . ;IHS/SD/lwj 03/10/04 patch 10 end change

 . . E  S NDC=""

 . . S VISIT=$P($G(^PSRX(RXI,1,RXR,999999911)),U)

 . E  D  ; first fill

 . . S FILLDATE=$P(^PSRX(RXI,2),U,2),RXR=0

 . . I NDCDEF S NDC=$P(^PSRX(RXI,2),U,7)

 . . E  S NDC=""

 . . S VISIT=$P($G(^PSRX(RXI,999999911)),U)

 . S FILLDATE=$$MMMDD(FILLDATE)

 . I VISIT D  ; got to follow the PCC link - we aren't at VISIT yet!

 . . S VISIT=$P($G(^AUPNVMED(VISIT,0)),U,3)

 E  I X?1"V`"1N.N D  ; a visit

 . S VISIT=$P(X,"`",2) N V0 S V0=^AUPNVSIT(VISIT,0)

 . S RX=$P($G(^AUPNVSIT(VISIT,"VCN")),U)

 . I RX="" S RX=X ; display the V`VSTDFN form if no VCN defined yet

 . S NDC="" ; no default for charge code

 . S PAT=$P(V0,U,5)

 . S PATNAME=$P(^DPT(PAT,0),U)

 . S DRUGNAME="" ; no charge item yet

 . S (RXI,RXR,AWPMED)="" ; no prescription

 . S FILLDATE=$$MMMDD($P($P(V0,U),"@"))

 E  I X="DELETE" D

 . S (RX,NDC,PATNAME,DRUGNAME,FILLDATE)=""

 ;S:RX="" RX=" " S:NDC="" NDC=" " S:PATNAME="" PATNAME=" "

 ;S:DRUGNAME="" DRUGNAME=" " S:FILLDATE="" FILLDATE=" "

 D PUT^DDSVAL(DIE,.DA,.02,RX)

 ; if you have a default NDC number, don't store unless field is empty.

 I $$GET^DDSVAL(DIE,.DA,.03)=""!1 D PUT^DDSVAL(DIE,.DA,.03,NDC)

 D PUT^DDSVAL(DIE,.DA,.04,PATNAME)

 D PUT^DDSVAL(DIE,.DA,.05,DRUGNAME)

 D PUT^DDSVAL(DIE,.DA,.06,FILLDATE)

 I X="DELETE" D  Q

 . ; delete all the other fields, too:

 . N F

 . F F=1.01:.01:1.07,2.01,5.01:.01:5.06,6.01:.01:6.03,7.01:.01:7.03 D

 . . D PUT^DDSVAL(DIE,.DA,F,"",,"I")

 . D ERASEALL^ABSPOSI8 ; the "I" multiple and page 8 details

 . S DDSBR="RX DISP" ; and go back to the RX field

 ; For others (not the DELETE case):

 D PUT^DDSVAL(DIE,.DA,1.01,$G(RXI),,"I")

 D PUT^DDSVAL(DIE,.DA,1.02,$G(RXR),,"I")

 D PUT^DDSVAL(DIE,.DA,1.03,$G(DRUG),,"I")

 D PUT^DDSVAL(DIE,.DA,1.04,$G(PAT),,"I")

 D PUT^DDSVAL(DIE,.DA,1.05,$G(AWPMED),,"I")

 D PUT^DDSVAL(DIE,.DA,1.06,$G(VISIT),,"I")

 D PUT^DDSVAL(DIE,.DA,1.07,$G(IEN59),,"I")

 ;D FILLDATE^ABSPOSIB ; called from Branching Logic

 Q

MMMDD(Y) ;EP

 X ^DD("DD") Q $P(Y,",")

UPPER(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

ABSPOSI1  ; IHS/FCS/DRS - support for the prescrip. field on the form ;    [ 09/12/2002  10:10 AM ]

 +1       ;;1.0;PHARMACY POINT OF SALE;**3,10,44**;JUN 21, 2001;Build 38

 +2       ;----------------------------------------------------------------------

 +3       ;IHS/SD/lwj 03/10/04 patch 10

 +4       ; Routine adjusted to call ABSPFUNC to retrieve

 +5       ; the Prescription Refill NDC value.  At some

 +6       ; point the call needs to be modified to call APSPFUNC.

 +7       ; See ABSPFUNC for details on why call was done.

 +8       ;----------------------------------------------------------------------

 +9        QUIT 

ENABASK   ; enable the "Ask preauth?" etc. questions  

           DO THEASKS(0)

           QUIT 

DISABASK  ; disable those questions

           DO THEASKS(1)

           QUIT 

THEASKS(N) ; don't use this directly, the 0/1 meanings are backwards 

 +1       ; from what you would think they mean (0 enables, 1 disables)

 +2        NEW PAGE,BLOCK

           SET PAGE=1

           SET BLOCK=1

 +3        NEW F

           FOR F=12,14,16,18,20

               Begin DoDot:1

 +4       ;I N=0,F=18 Q  ; NOT IMPLEM'D - DON'T ENABLE

 +5                DO UNED^DDSUTL(F,BLOCK,PAGE,N)

               End DoDot:1

 +6        QUIT 

VALID     ; VALID is the Data Validation action for the field.

 +1       ; It may invoke prescription or visit lookup.

 +2       ; It might reset X and DDSEXT. 

 +3       ;D MSGWAIT("We are in VALID^"_$T(+0)_" with X="_$G(X)_", DDSEXT="_$G(DDSEXT))

 +4        NEW Z

           SET Z=$$VALIDATE(X)

 +5       ;D MSGWAIT("VALIDATE^() returns and we have Z="_Z)

 +6        SET (X,DDSEXT)=Z

 +7       ;D MSGWAIT("On the way out, we have set X="_$G(X)_" and DDSEXT="_$G(DDSEXT))

 +8        QUIT 

VALIDATE(X) ;  validate input and return transformed value 

 +1       ; Returns -1 if error and sets DDSERROR

 +2       ;D MSGWAIT("We are in VALIDATE^"_$T(+0)_" with X="_$G(X))

 +3        KILL DDSERROR

 +4       ; = "RX" or "VISIT"

           NEW TYPE

 +5       ;

VAL1      ; ELSE each possibility:

           IF 0

 +1       ; ANMC bar code labels

          IF '$TEST

               IF X?1N.N1"-"1N.N

                   Begin DoDot:1

 +2                    SET TYPE="RX"

 +3                    SET X="`"_$PIECE(X,"-",2)

 +4                    SET X=$$RXLOOKUP(X,"NOX")

 +5                    IF X<0

                           SET DDSERROR=1

                   End DoDot:1

 +6       ; Sitka

          IF '$TEST

               IF X?1N.N

                   IF $PIECE($GET(^ABSP(9002313.99,1,"INPUT")),U)=0

                       Begin DoDot:1

 +7                        SET TYPE="RX"

 +8                        SET X="`"_+X

 +9                        SET X=$$RXLOOKUP(X,"NOX")

 +10                       IF X<0

                               SET DDSERROR=2

                       End DoDot:1

 +11      ; internal RX number input ; 10/26/2000

          IF '$TEST

               IF X?1"`"1N.N

                   Begin DoDot:1

 +12                   SET TYPE="RX"

                       SET X=$$RXLOOKUP(X,"NOX")

                       IF X<0

                           SET DDSERROR=6

                   End DoDot:1

VAL2      ;

 +1       ;external RX # input

          IF '$TEST

               IF X?1N.N0.1A!($$UPPER(X)?1"RX".P1N.N0.1A)

                   Begin DoDot:1

 +2                    SET TYPE="RX"

 +3                    IF $$UPPER(X)?1"RX".E

                           Begin DoDot:2

 +4                            SET X=$PIECE(X,"RX",2)

                               FOR 

                                   IF $EXTRACT(X)?1N

                                       QUIT 

                                   SET X=$EXTRACT(X,2,$LENGTH(X))

                           End DoDot:2

 +5                    SET X=$$RXLOOKUP(X,"OX")

 +6                    IF X<0

                           SET DDSERROR=5

                   End DoDot:1

 +7       ; null (includes "@")

          IF '$TEST

               IF X=""

                   Begin DoDot:1

 +8                    SET X="DELETE"

                   End DoDot:1

 +9       IF '$TEST

               IF $$UPPER(X)=$EXTRACT("FIND",1,$LENGTH(X))

                   Begin DoDot:1

 +10      ; might change to VISIT, below

                       SET TYPE="RX"

 +11      ; RESET^DDS is the wrong thing to do here

 +12      ; try it without this, too  D FULLSCRE

 +13                   WRITE @IOF

 +14      ; = RXI^RXR if presc,  = VISITIEN if visit

                       SET X=$$RXFIND^ABSPOSIF

 +15                   DO REFRESH^DDSUTL

 +16                   IF X<0

                           SET DDSERROR=3

                           QUIT 

 +17                   IF $LENGTH(X,U)=1

                           SET TYPE="VISIT"

                   End DoDot:1

 +18      ; VCN number

          IF '$TEST

               IF X?0.1U1N.N1"."1N.N1U

                   Begin DoDot:1

 +19      ; it might change to RX, below

                       SET TYPE="VISIT"

 +20                   SET X=$ORDER(^AUPNVSIT("VCN",X,0))

 +21                   WRITE @IOF

 +22      ; 

                       SET X=$$RXFIND^ABSPOSIF(,,X)

 +23                   DO REFRESH^DDSUTL

 +24                   IF 'X

                           SET DDSERROR=4

                           SET X=-1

 +25                   IF $LENGTH(X,U)=2

                           SET TYPE="RX"

                   End DoDot:1

 +26      IF '$TEST

               IF $LENGTH(X)'<3

                   IF $$UPPER(X)=$EXTRACT("DELETE",1,$LENGTH(X))

                       Begin DoDot:1

 +27      ; and let EFFECTS do the dirty work later

                           SET X="DELETE"

                       End DoDot:1

 +28      ; if it didn't hit any of the recognized cases:

          IF '$TEST

               Begin DoDot:1

 +29               SET X=-1

                   SET DDSERROR=999

               End DoDot:1

 +30      ; And now deal with the results

 +31       IF X>0

               Begin DoDot:1

 +32      ; X=RXI or RXI^RXR

                   IF TYPE="RX"

                       Begin DoDot:2

 +33      ; RXR part will be dealt with in EFFECTS

                           SET X="`"_X

                       End DoDot:2

 +34      ; X points to ^AUPNVSIT

                  IF '$TEST

                       IF TYPE="VISIT"

                           Begin DoDot:2

 +35      ; may be changed to VCN in EFFECTS

                               SET X="V`"_X

                           End DoDot:2

               End DoDot:1

 +36      ; nothing needs to be done ; it's `RXI

          IF '$TEST

               IF X?1"`"1N.N

 +37      ; okay, nothing to do here ; EFFECTS takes care of it

          IF '$TEST

               IF X="DELETE"

 +38      ; okay, EFFECTS takes care of it

          IF '$TEST

               IF X="@"

 +39      ; DDSERROR should already be set.

          IF '$TEST

               IF X=-1

                   Begin DoDot:1

 +40                   DO HELP^ABSPOSI1

                   End DoDot:1

 +41      IF '$TEST

               DO IMPOSS^ABSPOSUE("P","TI","Unexpected case: X="_X,,"VAL2",$TEXT(+0))

 +42       QUIT X

FULLSCRE  ; adapted from FULL^VALM1

 +1        SET IOTM=1

           SET IOBM=IOSL

           WRITE IOSC

           WRITE @IOSTBM

           WRITE IORC

           QUIT 

RXLOOKUP(X,DIC0) ; lookup by `IEN or prescrip # or patient name or whatever

 +1        NEW DIC,Y,DUOUT,DTOUT

           SET DIC="^PSRX("

           SET DIC(0)=DIC0

 +2       ;S ^TMP($T(+0),$J," 0 RXLOOKUP^DIC")=$H

 +3       ;S ^TMP($T(+0),$J," 1 RXLOOKUP^DIC X^DIC0=")=$G(X)_U_$G(DIC0)

 +4        DO ^DIC

 +5        NEW RET

           SET RET=$SELECT(Y>0:"`"_+Y,1:-1)

 +6       ; put screen back together

           IF DIC0["A"

               DO REFRESH^DDSUTL

 +7       ;S ^TMP($T(+0),$J," 2 RXLOOKUP^DIC RET=")=RET

 +8        QUIT RET

HELP      ;EP -

 +1        NEW AR,N

           SET N=0

 +2        DO HELP1("Scan the prescription label.")

 +3        DO HELP1("Or, you can enter ` followed by the internal number.")

 +4        DO HELP1("Or, type F or FIND to lookup by patient name.")

 +5        DO HELP1("Or, type the VCN number (non-prescription charges only).")

 +6        IF $$GET^DDSVAL(DIE,.DA,.02)]""

               DO HELP1("Answer with   @    to delete this line.")

 +7        DO HLP^DDSUTL(.AR)

 +8        QUIT 

HELP1(X)   SET N=N+1

           SET AR(N)=X

           QUIT 

MSGWAIT(X) ;EP - from ABSPOSI2,ABSPOSI8

 +1        NEW AR

           SET AR(1)=X

 +2       ; ,AR(2)="$$EOP" 

 +3        DO HLP^DDSUTL(.AR)

 +4        DO HLP^DDSUTL("$$EOP")

 +5        QUIT 

EFFECTS   ; side effects of putting a value in the prescription field

           NEW ERR

 +1        NEW RX,NDC,PATNAME,DRUGNAME,FILLDATE

 +2        NEW RXI,RXR,DRUG,PAT,AWPMED,VISIT,IEN59

 +3       ; NDCDEF - not a field on the form, so this cheap fetch is okay

 +4        NEW NDCDEF

           SET NDCDEF=$PIECE($GET(^ABSP(9002313.51,DA(1),100)),U)

 +5       ; It's a prescription:

           IF X?1"`"1N.N!(X?1"`"1N.N1"^"1N.N)

               Begin DoDot:1

 +6       ; Refill may or may not have been specified (FIND leads to 2nd piece)

 +7                IF $LENGTH(X,U)>1

                       SET RXR=$PIECE(X,U,2)

                       SET X=$PIECE(X,U)

 +8               IF '$TEST

                       SET RXR=$ORDER(^PSRX($PIECE(X,"`",2),1," "),-1)

 +9       ; display the `internal form

                   SET RX=X

                   SET RXI=$PIECE(X,"`",2)

 +10               NEW R0

                   SET R0=$GET(^PSRX(RXI,0))

                   IF R0=""

                       DO IMPOSS^ABSPOSUE("DB,P","TI","VALIDATE should have caught this",,"EFFECTS",$TEXT(+0))

 +11               SET PAT=$PIECE(R0,U,2)

 +12               SET PATNAME=$PIECE(^DPT(PAT,0),U)

 +13      ; get pointer to drug file ; ABSP*1.0T7*11 ; removed "N DRUG", the NEW happened at the calling level and DRUG is needed below

                   SET DRUG=$PIECE(R0,U,6)

 +14      ;OIT/CAS/RCS 10022012 - Patch 44, only allow 40 characters for the drug name, HEAT # 86226

 +15      ; get drug name

                   IF DRUG

                       SET DRUGNAME=$EXTRACT($PIECE($GET(^PSDRUG(DRUG,0)),U),1,40)

 +16              IF '$TEST

                       SET DRUGNAME="?missing from ^PSRX?"

 +17      ; refill

                   IF RXR

                       Begin DoDot:2

 +18      ;$O(^PSRX(X,1,"B",""),-1)

                           SET FILLDATE=$PIECE(^PSRX(RXI,1,RXR,0),U)

 +19      ;IHS/SD/lwj 03/10/04 patch 10 nxt line rmkd out, new line added

 +20      ;I NDCDEF S NDC=$P(^PSRX(RXI,1,RXR,0),U,13)

 +21      ;patch 10

                           IF NDCDEF

                               SET NDC=$$NDCVAL^ABSPFUNC(RXI,RXR)

 +22      ;IHS/SD/lwj 03/10/04 patch 10 end change

 +23                      IF '$TEST

                               SET NDC=""

 +24                       SET VISIT=$PIECE($GET(^PSRX(RXI,1,RXR,999999911)),U)

                       End DoDot:2

 +25      ; first fill

                  IF '$TEST

                       Begin DoDot:2

 +26                       SET FILLDATE=$PIECE(^PSRX(RXI,2),U,2)

                           SET RXR=0

 +27                       IF NDCDEF

                               SET NDC=$PIECE(^PSRX(RXI,2),U,7)

 +28                      IF '$TEST

                               SET NDC=""

 +29                       SET VISIT=$PIECE($GET(^PSRX(RXI,999999911)),U)

                       End DoDot:2

 +30               SET FILLDATE=$$MMMDD(FILLDATE)

 +31      ; got to follow the PCC link - we aren't at VISIT yet!

                   IF VISIT

                       Begin DoDot:2

 +32                       SET VISIT=$PIECE($GET(^AUPNVMED(VISIT,0)),U,3)

                       End DoDot:2

               End DoDot:1

 +33      ; a visit

          IF '$TEST

               IF X?1"V`"1N.N

                   Begin DoDot:1

 +34                   SET VISIT=$PIECE(X,"`",2)

                       NEW V0

                       SET V0=^AUPNVSIT(VISIT,0)

 +35                   SET RX=$PIECE($GET(^AUPNVSIT(VISIT,"VCN")),U)

 +36      ; display the V`VSTDFN form if no VCN defined yet

                       IF RX=""

                           SET RX=X

 +37      ; no default for charge code

                       SET NDC=""

 +38                   SET PAT=$PIECE(V0,U,5)

 +39                   SET PATNAME=$PIECE(^DPT(PAT,0),U)

 +40      ; no charge item yet

                       SET DRUGNAME=""

 +41      ; no prescription

                       SET (RXI,RXR,AWPMED)=""

 +42                   SET FILLDATE=$$MMMDD($PIECE($PIECE(V0,U),"@"))

                   End DoDot:1

 +43      IF '$TEST

               IF X="DELETE"

                   Begin DoDot:1

 +44                   SET (RX,NDC,PATNAME,DRUGNAME,FILLDATE)=""

                   End DoDot:1

 +45      ;S:RX="" RX=" " S:NDC="" NDC=" " S:PATNAME="" PATNAME=" "

 +46      ;S:DRUGNAME="" DRUGNAME=" " S:FILLDATE="" FILLDATE=" "

 +47       DO PUT^DDSVAL(DIE,.DA,.02,RX)

 +48      ; if you have a default NDC number, don't store unless field is empty.

 +49       IF $$GET^DDSVAL(DIE,.DA,.03)=""!1

               DO PUT^DDSVAL(DIE,.DA,.03,NDC)

 +50       DO PUT^DDSVAL(DIE,.DA,.04,PATNAME)

 +51       DO PUT^DDSVAL(DIE,.DA,.05,DRUGNAME)

 +52       DO PUT^DDSVAL(DIE,.DA,.06,FILLDATE)

 +53       IF X="DELETE"

               Begin DoDot:1

 +54      ; delete all the other fields, too:

 +55               NEW F

 +56               FOR F=1.01:.01:1.07,2.01,5.01:.01:5.06,6.01:.01:6.03,7.01:.01:7.03

                       Begin DoDot:2

 +57                       DO PUT^DDSVAL(DIE,.DA,F,"",,"I")

                       End DoDot:2

 +58      ; the "I" multiple and page 8 details

                   DO ERASEALL^ABSPOSI8

 +59      ; and go back to the RX field

                   SET DDSBR="RX DISP"

               End DoDot:1

               QUIT 

 +60      ; For others (not the DELETE case):

 +61       DO PUT^DDSVAL(DIE,.DA,1.01,$GET(RXI),,"I")

 +62       DO PUT^DDSVAL(DIE,.DA,1.02,$GET(RXR),,"I")

 +63       DO PUT^DDSVAL(DIE,.DA,1.03,$GET(DRUG),,"I")

 +64       DO PUT^DDSVAL(DIE,.DA,1.04,$GET(PAT),,"I")

 +65       DO PUT^DDSVAL(DIE,.DA,1.05,$GET(AWPMED),,"I")

 +66       DO PUT^DDSVAL(DIE,.DA,1.06,$GET(VISIT),,"I")

 +67       DO PUT^DDSVAL(DIE,.DA,1.07,$GET(IEN59),,"I")

 +68      ;D FILLDATE^ABSPOSIB ; called from Branching Logic

 +69       QUIT 

MMMDD(Y)  ;EP

 +1        XECUTE ^DD("DD")

           QUIT $PIECE(Y,",")

UPPER(X)   QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")