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")
