APCLREF1 ; IHS/CMI/LAB - list refusals ;
;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
;
;
INFORM ;
W !,$$CTR($$USR)
W !,$$LOC()
W !!,$$CTR("LISTING OF PATIENT SERVICES NOT DONE",80)
W !!,"This report will list all services not done (refusals) documented for patients.",!,"You will be given the opportunity to specify which reasons not done (type of refusals)",!,"and the date range of the services not done.",!
W !
TYPE ;type of refusal all or one?
S APCLTYPE=""
S DIR(0)="Y",DIR("A")="Do you want to include ALL Reasons not done?",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G EOJ
S APCLTYPE=Y
I APCLTYPE G DATES
TYPE1 ;which refusal type?
S APCLTYP1=""
K DIC S DIC="^AUTTREFT(",DIC(0)="AEMQ",DIC("A")="Enter the REASON NOT DONE: " D ^DIC K DIC
I Y=-1 G TYPE
S APCLTYP1=+Y
ID ;
S APCLID="",APCLONE=""
S DIR(0)="S^A:ALL "_$P(^AUTTREFT(APCLTYP1,0),U)_" reasons not done;O:ONE "_$P(^AUTTREFT(APCLTYP1,0),U)_" reason not done"
S DIR("A")="Do you want one particular "_$P(^AUTTREFT(APCLTYP1,0),U)_" reason not done or all",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G TYPE
S APCLID=Y
G:APCLID="A" DATES
;call to do lookup into file
S APCLONE="",APCLONEP=""
K DIC S DIC=$P(^AUTTREFT(APCLTYP1,0),U,2),DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 G TYPE
S APCLONE=+Y,APCLONEP=$P(Y,U,2)
DATES K APCLED,APCLBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Refusal/Declined Service Date"
D ^DIR Q:Y<1 S APCLBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Refusal/Declined Service Date"
D ^DIR Q:Y<1 S APCLED=Y
;
I APCLED<APCLBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
ZIS ;
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G DATES
S XBRP="PRINT^APCLREF1",XBRC="PROC^APCLREF1",XBRX="EOJ^APCLREF1",XBNS="APCL"
D ^XBDBQUE
D EOJ
Q
EOJ ;
D EN^XBVK("APCL")
D ^XBFMK
Q
PROC ;
S APCLIMM=$O(^AUTTREFT("B","IMMUNIZATION",0))
S APCLCNT=0
S APCLH=$H,APCLJ=$J
K ^XTMP("APCLREF1",APCLJ,APCLH)
D XTMP^APCLOSUT("APCLREF1","REFUSALS REPORT")
S APCLX=0 F S APCLX=$O(^AUPNPREF(APCLX)) Q:APCLX'=+APCLX D
.Q:$$DEMO^APCLUTL($P(^AUPNPREF(APCLX,0),U,2),$G(APCLDEMO))
.S APCLD=$P(^AUPNPREF(APCLX,0),U,3)
.Q:APCLBD>APCLD
.Q:APCLED<APCLD
.I 'APCLTYPE,$P(^AUPNPREF(APCLX,0),U)'=APCLTYP1 Q ;want one type and this isn't it
.I $G(APCLONE),$P(^AUPNPREF(APCLX,0),U,6)'=APCLONE Q ;want only one and this isn't it
.S APCLCNT=APCLCNT+1
.S ^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",$P(^AUPNPREF(APCLX,0),U),$S($P(^AUPNPREF(APCLX,0),U,4)]"":$P(^AUPNPREF(APCLX,0),U,4),1:"???"),$$VAL^XBDIQ1(9000022,APCLX,.02),APCLX)=""
.Q
I $G(APCLTYP1),APCLTYP1'=APCLIMM Q
S APCLX=0 F S APCLX=$O(^BIPC(APCLX)) Q:APCLX'=+APCLX D
.S R=$P(^BIPC(APCLX,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(APCLX,0),U,4)
.Q:D=""
.Q:$P(^BIPC(APCLX,0),U,4)<APCLBD
.Q:$P(^BIPC(APCLX,0),U,4)>APCLED
.S I=$P(^BIPC(APCLX,0),U,2)
.I $G(APCLONE),I'=APCLONE Q
.S P=$P(^BIPC(APCLX,0),U)
.S ^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLIMM,I,$P(^DPT(P,0),U),APCLX)="I"
;
Q
PRINT ;EP - called from xbdbque
S APCLPG=0 K APCLQUIT
I '$D(^XTMP("APCLREF1",APCLJ,APCLH)) D HEADER W !!,"No data to report.",! G DONE
S APCLT="" F S APCLT=$O(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT)) Q:APCLT=""!($D(APCLQUIT)) D
.D HEADER Q:$D(APCLQUIT)
.W !,$P(^AUTTREFT(APCLT,0),U)," refusals",!
.S APCLT1="" F S APCLT1=$O(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1)) Q:APCLT1=""!($D(APCLQUIT)) D
..S APCLNAME="" F S APCLNAME=$O(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1,APCLNAME)) Q:APCLNAME=""!($D(APCLQUIT)) D
...S APCLR=0 F S APCLR=$O(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1,APCLNAME,APCLR)) Q:APCLR'=+APCLR D
....I $Y>(IOSL-3) D HEADER Q:$D(APCLQUIT)
....S APCLY=^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1,APCLNAME,APCLR)
....I APCLY="" S DFN=$P(^AUPNPREF(APCLR,0),U,2)
....I APCLY="I" S DFN=$P(^BIPC(APCLR,0),U)
....W !,$E(APCLNAME,1,21),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$DOB^AUPNPAT(DFN,"E")
....I APCLY="" W ?42,$$VAL^XBDIQ1(9000022,APCLR,.03),?55,$E(APCLT1,1,15),?71,$E($$VAL^XBDIQ1(9000022,APCLR,.07),1,7)
....I APCLY="I" W ?42,$$VAL^XBDIQ1(9002084.11,APCLR,.04),?55,$E(APCLT1,1,15),?71,$E($$VAL^XBDIQ1(9002084.11,APCLR,.03),1,7)
D DONE
Q
G:'APCLPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
W !,$$CTR("*** PATIENT REFUSAL/DECLINED SERVICE LISTING ***",80),!
S X=$S(APCLTYPE:"ALL REASONS NOT DONE (REFUSAL TYPES)",1:$P(^AUTTREFT(APCLTYP1,0),U)_" REASONS NOT DONE (REFUSALS)") W $$CTR(X,80),!
I $G(APCLONE)]"" W $$CTR(APCLONEP_" refusals",80),!
S X="Declined Service Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!
W !,"PATIENT NAME",?22,"HRN",?29,"DOB",?42,"DATE",?55,"ITEM",?71,"REASON"
W !,$TR($J("",80)," ","-")
Q
DONE ;
K ^XTMP("APCLREF1",APCLJ,APCLH)
D EOP
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:IO'=IO(0)
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
W !
S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
APCLREF1 ; IHS/CMI/LAB - list refusals ;
+1 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
INFORM ;
+1 WRITE !,$$CTR($$USR)
+2 WRITE !,$$LOC()
+3 WRITE !!,$$CTR("LISTING OF PATIENT SERVICES NOT DONE",80)
+4 WRITE !!,"This report will list all services not done (refusals) documented for patients.",!,"You will be given the opportunity to specify which reasons not done (type of refusals)",!,"and the date range of the services not done.",!
+5 WRITE !
TYPE ;type of refusal all or one?
+1 SET APCLTYPE=""
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to include ALL Reasons not done?"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO EOJ
+4 SET APCLTYPE=Y
+5 IF APCLTYPE
GOTO DATES
TYPE1 ;which refusal type?
+1 SET APCLTYP1=""
+2 KILL DIC
SET DIC="^AUTTREFT("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the REASON NOT DONE: "
DO ^DIC
KILL DIC
+3 IF Y=-1
GOTO TYPE
+4 SET APCLTYP1=+Y
ID ;
+1 SET APCLID=""
SET APCLONE=""
+2 SET DIR(0)="S^A:ALL "_$PIECE(^AUTTREFT(APCLTYP1,0),U)_" reasons not done;O:ONE "_$PIECE(^AUTTREFT(APCLTYP1,0),U)_" reason not done"
+3 SET DIR("A")="Do you want one particular "_$PIECE(^AUTTREFT(APCLTYP1,0),U)_" reason not done or all"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO TYPE
+5 SET APCLID=Y
+6 IF APCLID="A"
GOTO DATES
+7 ;call to do lookup into file
+8 SET APCLONE=""
SET APCLONEP=""
+9 KILL DIC
SET DIC=$PIECE(^AUTTREFT(APCLTYP1,0),U,2)
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+10 IF Y=-1
GOTO TYPE
+11 SET APCLONE=+Y
SET APCLONEP=$PIECE(Y,U,2)
DATES KILL APCLED,APCLBD
+1 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Refusal/Declined Service Date"
+2 DO ^DIR
IF Y<1
QUIT
SET APCLBD=Y
+3 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Refusal/Declined Service Date"
+4 DO ^DIR
IF Y<1
QUIT
SET APCLED=Y
+5 ;
+6 IF APCLED<APCLBD
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+8 ;
ZIS ;
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO DATES
+3 SET XBRP="PRINT^APCLREF1"
SET XBRC="PROC^APCLREF1"
SET XBRX="EOJ^APCLREF1"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 DO EOJ
+6 QUIT
EOJ ;
+1 DO EN^XBVK("APCL")
+2 DO ^XBFMK
+3 QUIT
PROC ;
+1 SET APCLIMM=$ORDER(^AUTTREFT("B","IMMUNIZATION",0))
+2 SET APCLCNT=0
+3 SET APCLH=$HOROLOG
SET APCLJ=$JOB
+4 KILL ^XTMP("APCLREF1",APCLJ,APCLH)
+5 DO XTMP^APCLOSUT("APCLREF1","REFUSALS REPORT")
+6 SET APCLX=0
FOR
SET APCLX=$ORDER(^AUPNPREF(APCLX))
IF APCLX'=+APCLX
QUIT
Begin DoDot:1
+7 IF $$DEMO^APCLUTL($PIECE(^AUPNPREF(APCLX,0),U,2),$GET(APCLDEMO))
QUIT
+8 SET APCLD=$PIECE(^AUPNPREF(APCLX,0),U,3)
+9 IF APCLBD>APCLD
QUIT
+10 IF APCLED<APCLD
QUIT
+11 ;want one type and this isn't it
IF 'APCLTYPE
IF $PIECE(^AUPNPREF(APCLX,0),U)'=APCLTYP1
QUIT
+12 ;want only one and this isn't it
IF $GET(APCLONE)
IF $PIECE(^AUPNPREF(APCLX,0),U,6)'=APCLONE
QUIT
+13 SET APCLCNT=APCLCNT+1
+14 SET ^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",$PIECE(^AUPNPREF(APCLX,0),U),$SELECT($PIECE(^AUPNPREF(APCLX,0),U,4)]"":$PIECE(^AUPNPREF(APCLX,0),U,4),1:"???"),$$VAL^XBDIQ1(9000022,APCLX,.02),APCLX)=""
+15 QUIT
End DoDot:1
+16 IF $GET(APCLTYP1)
IF APCLTYP1'=APCLIMM
QUIT
+17 SET APCLX=0
FOR
SET APCLX=$ORDER(^BIPC(APCLX))
IF APCLX'=+APCLX
QUIT
Begin DoDot:1
+18 SET R=$PIECE(^BIPC(APCLX,0),U,3)
+19 IF R=""
QUIT
+20 IF '$DATA(^BICONT(R,0))
QUIT
+21 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+22 SET D=$PIECE(^BIPC(APCLX,0),U,4)
+23 IF D=""
QUIT
+24 IF $PIECE(^BIPC(APCLX,0),U,4)<APCLBD
QUIT
+25 IF $PIECE(^BIPC(APCLX,0),U,4)>APCLED
QUIT
+26 SET I=$PIECE(^BIPC(APCLX,0),U,2)
+27 IF $GET(APCLONE)
IF I'=APCLONE
QUIT
+28 SET P=$PIECE(^BIPC(APCLX,0),U)
+29 SET ^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLIMM,I,$PIECE(^DPT(P,0),U),APCLX)="I"
End DoDot:1
+30 ;
+31 QUIT
PRINT ;EP - called from xbdbque
+1 SET APCLPG=0
KILL APCLQUIT
+2 IF '$DATA(^XTMP("APCLREF1",APCLJ,APCLH))
DO HEADER
WRITE !!,"No data to report.",!
GOTO DONE
+3 SET APCLT=""
FOR
SET APCLT=$ORDER(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT))
IF APCLT=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+4 DO HEADER
IF $DATA(APCLQUIT)
QUIT
+5 WRITE !,$PIECE(^AUTTREFT(APCLT,0),U)," refusals",!
+6 SET APCLT1=""
FOR
SET APCLT1=$ORDER(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1))
IF APCLT1=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:2
+7 SET APCLNAME=""
FOR
SET APCLNAME=$ORDER(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1,APCLNAME))
IF APCLNAME=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:3
+8 SET APCLR=0
FOR
SET APCLR=$ORDER(^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1,APCLNAME,APCLR))
IF APCLR'=+APCLR
QUIT
Begin DoDot:4
+9 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCLQUIT)
QUIT
+10 SET APCLY=^XTMP("APCLREF1",APCLJ,APCLH,"REFUSALS",APCLT,APCLT1,APCLNAME,APCLR)
+11 IF APCLY=""
SET DFN=$PIECE(^AUPNPREF(APCLR,0),U,2)
+12 IF APCLY="I"
SET DFN=$PIECE(^BIPC(APCLR,0),U)
+13 WRITE !,$EXTRACT(APCLNAME,1,21),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$DOB^AUPNPAT(DFN,"E")
+14 IF APCLY=""
WRITE ?42,$$VAL^XBDIQ1(9000022,APCLR,.03),?55,$EXTRACT(APCLT1,1,15),?71,$EXTRACT($$VAL^XBDIQ1(9000022,APCLR,.07),1,7)
+15 IF APCLY="I"
WRITE ?42,$$VAL^XBDIQ1(9002084.11,APCLR,.04),?55,$EXTRACT(APCLT1,1,15),?71,$EXTRACT($$VAL^XBDIQ1(9002084.11,APCLR,.03),1,7)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 DO DONE
+17 QUIT
+1 IF 'APCLPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
+3 WRITE !,$$CTR("*** PATIENT REFUSAL/DECLINED SERVICE LISTING ***",80),!
+4 SET X=$SELECT(APCLTYPE:"ALL REASONS NOT DONE (REFUSAL TYPES)",1:$PIECE(^AUTTREFT(APCLTYP1,0),U)_" REASONS NOT DONE (REFUSALS)")
WRITE $$CTR(X,80),!
+5 IF $GET(APCLONE)]""
WRITE $$CTR(APCLONEP_" refusals",80),!
+6 SET X="Declined Service Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80),!
+7 WRITE !,"PATIENT NAME",?22,"HRN",?29,"DOB",?42,"DATE",?55,"ITEM",?71,"REASON"
+8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+9 QUIT
DONE ;
+1 KILL ^XTMP("APCLREF1",APCLJ,APCLH)
+2 DO EOP
+3 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF IO'=IO(0)
QUIT
+3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+4 NEW DIR
+5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 WRITE !
+7 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+8 QUIT
+9 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
