APCDEREF ; IHS/CMI/LAB - prompt for refusal value ; 23 May 2013 10:50 AM
;;2.0;IHS PCC SUITE;**11,17**;MAY 14, 2009;Build 18
;
IN ;EP
;lookup refusal type and create entry
I $G(APCDTREF)="" W !,"Refusal type missing.....!" Q
S APCDT02=$G(APCDPAT)
I APCDT02="" S APCDT02=$G(DFN)
I 'APCDT02 W !!,"Patient missing..." Q
D EN^XBNEW("IN1^APCDEREF","APCDTREF;APCDT02")
Q
IN1 ;EP - called from xbnew to create a refusal entry
S DIC="^AUTTREFT(",DIC(0)="AEMQ",DIC("A")="PATIENT REFUSALS FOR SERVICE/NMI SERVICE TYPE: "
D ^DIC
I Y=-1 Q
I $P(^AUTTREFT(+Y,0),U)="SNOMED" W !!,"That type of refusal cannot be entered through PCC Data Entry.",! Q
S APCDT01=+Y
VALUE ;EP - called from input template
S APCDTF=$P(^AUTTREFT(APCDT01,0),U,2)
I 'APCDTF W !!,"table file missing..." Q
K X,DUOUT,DIRUT
I $P(^AUTTREFT(APCDT01,0),U)="RXNORM" D RX Q
K DIC S DIC("B")=$S($D(APCDTOLD):APCDTOLD,1:""),DIC("A")=" Enter the "_$P(^DIC(APCDTF,0),U)_" value: ",DIC=APCDTF,DIC(0)="AEMQ"
;I APCDTF=80.1 S DIC("S")="D ICDOPCHK^AUPNSICD"
D ^DIC K DIC
I $P(Y,U)=-1 W !!,"Invalid entry. Try again." G VALUE
S APCDTFI=+Y
I APCDTF=80.1 S APCDTID=$P($$ICDOP^ICDEX(APCDTFI,,,"I"),U,5) I 1
E S APCDTID=$$VAL^XBDIQ1(APCDTF,APCDTFI,$P(^AUTTREFT(APCDT01,0),U,3))
D CENTRY ;create the entry and edit
EOJ ;
K Y
Q
;
CENTRY ;
I $G(APCDTDA) G CENTRYE
S X=APCDT01,DIC="^AUPNPREF(",DIC(0)="L",DIC("DR")=".02////"_APCDT02 K DD,DO,D0 D FILE^DICN K DIC
I Y=-1 W !,"ERROR CREATING ENTRY....TRY AGAIN..." Q
S APCDTDA=+Y
CENTRYE ;now edit it
;FIRST WIPE OUT FIELDS
S DA=APCDTDA,DIE="^AUPNPREF(",DR="1301///@;1302///@;.04///@;.05///@;.07///@" D ^DIE K DIE,DA,DR
S DIE("NO^")="",DA=APCDTDA,DIE="^AUPNPREF(",DR="[APCD REF ADD]" D ^DIE K DIE,DA,DR
Q
MOD(APCDP) ;EP
;select entry for modify and pass to template in APCDLOOK
S APCDTIEN=""
D EN^XBNEW("MOD1^APCDEREF","APCDP;APCDTIEN")
S APCDLOOK=$G(APCDTIEN)
I 'APCDLOOK W !!,"No entry selected" S APCDTERR=1 Q
Q
MOD1 ;EP called from xbnew
W !?2,"0) None"
NEW APCDX,APCDC,APCDD K APCDD S (APCDX,APCDC)=0
F S APCDX=$O(^AUPNPREF("AC",APCDP,APCDX)) Q:APCDX'=+APCDX S APCDC=APCDC+1,APCDD(APCDC)=APCDX W !?2,APCDC,")",?6,$E($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?22,$$VAL^XBDIQ1(9000022,APCDX,.04),?54,$$VAL^XBDIQ1(9000022,APCDX,.03)
S DIR(0)="N^0:99999:",DIR("A")="Which one do you wish to modify or delete",DIR("B")="0" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
S APCDTIEN=$G(APCDD(Y))
Q
MOD2 ;EP called from input template
D EN^XBNEW("VALUE^APCDEREF","APCDTMOD;APCDTDA;APCDT01;APCDTREF;APCDTOLD")
Q
EN(PATIENT,VFIEN) ;EP - called from APCD EL (ADD/MOD) templates
I '$G(PATIENT) Q
I '$G(VFIEN) Q
I '$D(^AUPNVELD(VFIEN)) Q
D EN^XBNEW("EN1^APCDEREF","VFIEN;PATIENT")
Q
EN1 ;EP - called from XBNEW to update elder care status
I '$D(^AUPNELDC("B",PATIENT)) G ADDEC
EDITEC ;
S DA=PATIENT,DIE="^AUPNELDC("
NEW VF
S VF=^AUPNVELD(VFIEN,0)
NEW D
S D=$P($P(^AUPNVSIT($P(^AUPNVELD(VFIEN,0),U,3),0),U),".")
I $P(^AUPNELDC(PATIENT,0),U,3)]D Q ;later entry already updated
S DR=".03////"_D_";.04////"_$P(VF,U,4)_";.05////"_$P(VF,U,5)_";.06////"_$P(VF,U,6)_";.07////"_$P(VF,U,7)_";.08////"_$P(VF,U,8)_";.09////"_$P(VF,U,9)_";.11////"_$P(VF,U,11)_";.12////"_$P(VF,U,12)_";.13////"_$P(VF,U,13)
S DR=DR_";.14////"_$P(VF,U,14)_";.15////"_$P(VF,U,15)_";.16////"_$P(VF,U,16)_";.17////"_$P(VF,U,17)_";.18////"_$P(VF,U,18)
D ^DIE
XIT ;
K DIADD,DLAYGO,DD,DO,D0,DIC
K DA,DIE,DIU,DIV,DIW,DR
Q
ADDEC ;
S DLAYGO=9000023,DIC="^AUPNELDC(",DIC(0)="L"
S X="`"_PATIENT
D ^DIC K DIC
I Y=-1 W !,"ERROR ADDING ELDER CARE STATUS ENTRY" D XIT Q
D EDITEC
Q
RX ;
;prompt for rxnorm code or text
;call bsts srch if not all numbers
K DIR
S (APCDTID,APCDTF,APCDTFI,APCDTDID)=""
S APCDTF=$P(^AUTTREFT(APCDT01,0),U,2)
W !
S DIR(0)="F^1:60",DIR("A")="Enter the RXNORM code or drug ingredient (or '^' to exit)" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S APCDRXN=Y
I APCDRXN?.N D I APCDTID="" G RX
.S APCDRXN1=$$CONC^BSTSAPI(APCDRXN_"^1552^^1")
.Q:$P(APCDRXN1,U)="" ;W !!,APCDRXN1 H 2
.W !!,$P(APCDRXN1,U,1)," ",$P(APCDRXN1,U,2)
.S (APCDTFI,APCDTCON)=APCDRXN
.S APCDTID=$P(APCDRXN1,U,2)
.S APCDTDID=$P(APCDRXN1,U,1)
.D CENTRY
.Q
I APCDRXN'?.N D I APCDTID="" G RX
.NEW OUT,VARS,IN,APCDC
.S OUT="VARS",IN=APCDRXN,$P(IN,U,2)="F",$P(IN,U,3)=1552 I $$SUBE("RXNO SRCH Drug Ingredients All") S $P(IN,U,4)="RXNO SRCH Drug Ingredients All"
.S APCDC=$$SEARCH^BSTSAPI(OUT,IN)
.I +APCDC<1 W !!,?9,"No entries found in the IHS STANDARD RXNORM TERMINOLOGY database."
.I +APCDC>0&(APCDC'=9999999) D GETANS
.I '$G(APCDY) Q
.S (APCDTFI,APCDTCON)=VARS(APCDY,"CON")
.S APCDTID=$G(VARS(APCDY,"FSN","TRM"))
.S APCDTDID=$G(VARS(APCDY,"FSN","DSC"))
.D CENTRY
.Q
Q
GETANS ;EP - DISPLAY RXNORM ARRAY
NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF
S MF=0
S Z=0 F S Z=$O(VARS(Z)) Q:Z'=+Z S MF=MF+1
W !!?5,MF," matches found.",!
S APCDX=0,APCDY="",APCDQ=0,APCDCNT=0,APCDTOT=0
F S APCDX=$O(VARS(APCDX)) Q:APCDX'=+APCDX!(APCDY]"") D
DISP .;display code
.W !?3,APCDX,")"
.S APCDZ=$G(VARS(APCDX,"FSN","TRM"))
.I APCDX="" S APCDX="MISSING FULLY SPECIFIED TERM"
.K ^UTILITY($J)
.S X=APCDZ,DIWL=0,DIWR=70 D ^DIWP
.S Z=0 F S Z=$O(^UTILITY($J,"W",0,Z)) Q:Z'=+Z W:Z>1 ! W ?9,^UTILITY($J,"W",0,Z,0)
.K ^UTILITY($J)
.S APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1
.I MF=1 S APCDCNT=1,APCDTOT=1 D READ S:APCDY="" APCDY="^" Q
.I MF>4,APCDCNT=5!(MF=APCDTOT) D READ S APCDCNT=0 Q
.I MF<5,MF=APCDX D READ S APCDNT=0 Q:APCDY]""
.Q
Q
READ ;
K DIR,DIRUT
S APCDY=""
W !
;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT
S DIR("B")=$S(MF=1:1,1:""),DIR(0)="NO^1:"_APCDTOT_":0"
S DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT
KILL DA D ^DIR W !
I $D(DIRUT) S APCDY="^"
I Y="" S APCDY="" Q
S APCDY=+Y
Q
SUBE(X) ;EP - does this subset exist?
NEW LST,Y,G
S G=""
S Y=$$SUBSET^BSTSAPI("LST",1552)
S Y=0 F S Y=$O(LST(Y)) Q:Y'=+Y!(G) D
.I $P(LST(Y),U,1)=X S G=1
.Q
Q G
APCDEREF ; IHS/CMI/LAB - prompt for refusal value ; 23 May 2013 10:50 AM
+1 ;;2.0;IHS PCC SUITE;**11,17**;MAY 14, 2009;Build 18
+2 ;
IN ;EP
+1 ;lookup refusal type and create entry
+2 IF $GET(APCDTREF)=""
WRITE !,"Refusal type missing.....!"
QUIT
+3 SET APCDT02=$GET(APCDPAT)
+4 IF APCDT02=""
SET APCDT02=$GET(DFN)
+5 IF 'APCDT02
WRITE !!,"Patient missing..."
QUIT
+6 DO EN^XBNEW("IN1^APCDEREF","APCDTREF;APCDT02")
+7 QUIT
IN1 ;EP - called from xbnew to create a refusal entry
+1 SET DIC="^AUTTREFT("
SET DIC(0)="AEMQ"
SET DIC("A")="PATIENT REFUSALS FOR SERVICE/NMI SERVICE TYPE: "
+2 DO ^DIC
+3 IF Y=-1
QUIT
+4 IF $PIECE(^AUTTREFT(+Y,0),U)="SNOMED"
WRITE !!,"That type of refusal cannot be entered through PCC Data Entry.",!
QUIT
+5 SET APCDT01=+Y
VALUE ;EP - called from input template
+1 SET APCDTF=$PIECE(^AUTTREFT(APCDT01,0),U,2)
+2 IF 'APCDTF
WRITE !!,"table file missing..."
QUIT
+3 KILL X,DUOUT,DIRUT
+4 IF $PIECE(^AUTTREFT(APCDT01,0),U)="RXNORM"
DO RX
QUIT
+5 KILL DIC
SET DIC("B")=$SELECT($DATA(APCDTOLD):APCDTOLD,1:"")
SET DIC("A")=" Enter the "_$PIECE(^DIC(APCDTF,0),U)_" value: "
SET DIC=APCDTF
SET DIC(0)="AEMQ"
+6 ;I APCDTF=80.1 S DIC("S")="D ICDOPCHK^AUPNSICD"
+7 DO ^DIC
KILL DIC
+8 IF $PIECE(Y,U)=-1
WRITE !!,"Invalid entry. Try again."
GOTO VALUE
+9 SET APCDTFI=+Y
+10 IF APCDTF=80.1
SET APCDTID=$PIECE($$ICDOP^ICDEX(APCDTFI,,,"I"),U,5)
IF 1
+11 IF '$TEST
SET APCDTID=$$VAL^XBDIQ1(APCDTF,APCDTFI,$PIECE(^AUTTREFT(APCDT01,0),U,3))
+12 ;create the entry and edit
DO CENTRY
EOJ ;
+1 KILL Y
+2 QUIT
+3 ;
CENTRY ;
+1 IF $GET(APCDTDA)
GOTO CENTRYE
+2 SET X=APCDT01
SET DIC="^AUPNPREF("
SET DIC(0)="L"
SET DIC("DR")=".02////"_APCDT02
KILL DD,DO,D0
DO FILE^DICN
KILL DIC
+3 IF Y=-1
WRITE !,"ERROR CREATING ENTRY....TRY AGAIN..."
QUIT
+4 SET APCDTDA=+Y
CENTRYE ;now edit it
+1 ;FIRST WIPE OUT FIELDS
+2 SET DA=APCDTDA
SET DIE="^AUPNPREF("
SET DR="1301///@;1302///@;.04///@;.05///@;.07///@"
DO ^DIE
KILL DIE,DA,DR
+3 SET DIE("NO^")=""
SET DA=APCDTDA
SET DIE="^AUPNPREF("
SET DR="[APCD REF ADD]"
DO ^DIE
KILL DIE,DA,DR
+4 QUIT
MOD(APCDP) ;EP
+1 ;select entry for modify and pass to template in APCDLOOK
+2 SET APCDTIEN=""
+3 DO EN^XBNEW("MOD1^APCDEREF","APCDP;APCDTIEN")
+4 SET APCDLOOK=$GET(APCDTIEN)
+5 IF 'APCDLOOK
WRITE !!,"No entry selected"
SET APCDTERR=1
QUIT
+6 QUIT
MOD1 ;EP called from xbnew
+1 WRITE !?2,"0) None"
+2 NEW APCDX,APCDC,APCDD
KILL APCDD
SET (APCDX,APCDC)=0
+3 FOR
SET APCDX=$ORDER(^AUPNPREF("AC",APCDP,APCDX))
IF APCDX'=+APCDX
QUIT
SET APCDC=APCDC+1
SET APCDD(APCDC)=APCDX
WRITE !?2,APCDC,")",?6,$EXTRACT($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?22,$$VAL^XBDIQ1(9000022,APCDX,.04),?54,$$VAL^XBDIQ1(9000022,APCDX,.03)
+4 SET DIR(0)="N^0:99999:"
SET DIR("A")="Which one do you wish to modify or delete"
SET DIR("B")="0"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 IF 'Y
QUIT
+7 SET APCDTIEN=$GET(APCDD(Y))
+8 QUIT
MOD2 ;EP called from input template
+1 DO EN^XBNEW("VALUE^APCDEREF","APCDTMOD;APCDTDA;APCDT01;APCDTREF;APCDTOLD")
+2 QUIT
EN(PATIENT,VFIEN) ;EP - called from APCD EL (ADD/MOD) templates
+1 IF '$GET(PATIENT)
QUIT
+2 IF '$GET(VFIEN)
QUIT
+3 IF '$DATA(^AUPNVELD(VFIEN))
QUIT
+4 DO EN^XBNEW("EN1^APCDEREF","VFIEN;PATIENT")
+5 QUIT
EN1 ;EP - called from XBNEW to update elder care status
+1 IF '$DATA(^AUPNELDC("B",PATIENT))
GOTO ADDEC
EDITEC ;
+1 SET DA=PATIENT
SET DIE="^AUPNELDC("
+2 NEW VF
+3 SET VF=^AUPNVELD(VFIEN,0)
+4 NEW D
+5 SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVELD(VFIEN,0),U,3),0),U),".")
+6 ;later entry already updated
IF $PIECE(^AUPNELDC(PATIENT,0),U,3)]D
QUIT
+7 SET DR=".03////"_D_";.04////"_$PIECE(VF,U,4)_";.05////"_$PIECE(VF,U,5)_";.06////"_$PIECE(VF,U,6)_";.07////"_$PIECE(VF,U,7)_";.08////"_$PIECE(VF,U,8)_";.09////"_$PIECE(VF,U,9)_";.11////"_$PIECE(VF,U,11)_";.12////"_$PIECE(VF,U,12)_";.13////"_...
... $PIECE(VF,U,13)
+8 SET DR=DR_";.14////"_$PIECE(VF,U,14)_";.15////"_$PIECE(VF,U,15)_";.16////"_$PIECE(VF,U,16)_";.17////"_$PIECE(VF,U,17)_";.18////"_$PIECE(VF,U,18)
+9 DO ^DIE
XIT ;
+1 KILL DIADD,DLAYGO,DD,DO,D0,DIC
+2 KILL DA,DIE,DIU,DIV,DIW,DR
+3 QUIT
ADDEC ;
+1 SET DLAYGO=9000023
SET DIC="^AUPNELDC("
SET DIC(0)="L"
+2 SET X="`"_PATIENT
+3 DO ^DIC
KILL DIC
+4 IF Y=-1
WRITE !,"ERROR ADDING ELDER CARE STATUS ENTRY"
DO XIT
QUIT
+5 DO EDITEC
+6 QUIT
RX ;
+1 ;prompt for rxnorm code or text
+2 ;call bsts srch if not all numbers
+3 KILL DIR
+4 SET (APCDTID,APCDTF,APCDTFI,APCDTDID)=""
+5 SET APCDTF=$PIECE(^AUTTREFT(APCDT01,0),U,2)
+6 WRITE !
+7 SET DIR(0)="F^1:60"
SET DIR("A")="Enter the RXNORM code or drug ingredient (or '^' to exit)"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
QUIT
+9 SET APCDRXN=Y
+10 IF APCDRXN?.N
Begin DoDot:1
+11 SET APCDRXN1=$$CONC^BSTSAPI(APCDRXN_"^1552^^1")
+12 ;W !!,APCDRXN1 H 2
IF $PIECE(APCDRXN1,U)=""
QUIT
+13 WRITE !!,$PIECE(APCDRXN1,U,1)," ",$PIECE(APCDRXN1,U,2)
+14 SET (APCDTFI,APCDTCON)=APCDRXN
+15 SET APCDTID=$PIECE(APCDRXN1,U,2)
+16 SET APCDTDID=$PIECE(APCDRXN1,U,1)
+17 DO CENTRY
+18 QUIT
End DoDot:1
IF APCDTID=""
GOTO RX
+19 IF APCDRXN'?.N
Begin DoDot:1
+20 NEW OUT,VARS,IN,APCDC
+21 SET OUT="VARS"
SET IN=APCDRXN
SET $PIECE(IN,U,2)="F"
SET $PIECE(IN,U,3)=1552
IF $$SUBE("RXNO SRCH Drug Ingredients All")
SET $PIECE(IN,U,4)="RXNO SRCH Drug Ingredients All"
+22 SET APCDC=$$SEARCH^BSTSAPI(OUT,IN)
+23 IF +APCDC<1
WRITE !!,?9,"No entries found in the IHS STANDARD RXNORM TERMINOLOGY database."
+24 IF +APCDC>0&(APCDC'=9999999)
DO GETANS
+25 IF '$GET(APCDY)
QUIT
+26 SET (APCDTFI,APCDTCON)=VARS(APCDY,"CON")
+27 SET APCDTID=$GET(VARS(APCDY,"FSN","TRM"))
+28 SET APCDTDID=$GET(VARS(APCDY,"FSN","DSC"))
+29 DO CENTRY
+30 QUIT
End DoDot:1
IF APCDTID=""
GOTO RX
+31 QUIT
GETANS ;EP - DISPLAY RXNORM ARRAY
+1 NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF
+2 SET MF=0
+3 SET Z=0
FOR
SET Z=$ORDER(VARS(Z))
IF Z'=+Z
QUIT
SET MF=MF+1
+4 WRITE !!?5,MF," matches found.",!
+5 SET APCDX=0
SET APCDY=""
SET APCDQ=0
SET APCDCNT=0
SET APCDTOT=0
+6 FOR
SET APCDX=$ORDER(VARS(APCDX))
IF APCDX'=+APCDX!(APCDY]"")
QUIT
Begin DoDot:1
DISP ;display code
+1 WRITE !?3,APCDX,")"
+2 SET APCDZ=$GET(VARS(APCDX,"FSN","TRM"))
+3 IF APCDX=""
SET APCDX="MISSING FULLY SPECIFIED TERM"
+4 KILL ^UTILITY($JOB)
+5 SET X=APCDZ
SET DIWL=0
SET DIWR=70
DO ^DIWP
+6 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",0,Z))
IF Z'=+Z
QUIT
IF Z>1
WRITE !
WRITE ?9,^UTILITY($JOB,"W",0,Z,0)
+7 KILL ^UTILITY($JOB)
+8 SET APCDCNT=APCDCNT+1
SET APCDTOT=APCDTOT+1
+9 IF MF=1
SET APCDCNT=1
SET APCDTOT=1
DO READ
IF APCDY=""
SET APCDY="^"
QUIT
+10 IF MF>4
IF APCDCNT=5!(MF=APCDTOT)
DO READ
SET APCDCNT=0
QUIT
+11 IF MF<5
IF MF=APCDX
DO READ
SET APCDNT=0
IF APCDY]""
QUIT
+12 QUIT
End DoDot:1
+13 QUIT
READ ;
+1 KILL DIR,DIRUT
+2 SET APCDY=""
+3 WRITE !
+4 ;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT
+5 SET DIR("B")=$SELECT(MF=1:1,1:"")
SET DIR(0)="NO^1:"_APCDTOT_":0"
+6 SET DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT
+7 KILL DA
DO ^DIR
WRITE !
+8 IF $DATA(DIRUT)
SET APCDY="^"
+9 IF Y=""
SET APCDY=""
QUIT
+10 SET APCDY=+Y
+11
*** ERROR ***
SUBE(X) ;EP - does this subset exist?
+1 NEW LST,Y,G
+2 SET G=""
+3 SET Y=$$SUBSET^BSTSAPI("LST",1552)
+4 SET Y=0
FOR
SET Y=$ORDER(LST(Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:1
+5 IF $PIECE(LST(Y),U,1)=X
SET G=1
+6 QUIT
End DoDot:1
+7 QUIT G
