Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLAL3P

APCLAL3P.m

Go to the documentation of this file.
  1. APCLAL3P ; IHS/CMI/LAB - list refusals ; 10 Dec 2009 3:10 PM
  1. ;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
  1. ;
  1. ;
  1. PRINT ;EP - called from xbdbque
  1. D PRINT1
  1. D DONE
  1. Q
  1. PRINT1 ;
  1. S APCRPG=0 K APCRQUIT
  1. K APCRLSTP
  1. I '$D(^XTMP("APCLAL3",APCRJ,APCRH)) D HEADER W !!,"No data to report.",! G DONE
  1. D COVPAGE
  1. Q:$$END
  1. D HEADER
  1. S APCRTOT=APCRCNT
  1. S APCRPTOT=$$PTOT
  1. W !," Total Number of Visits with Screening",?40,$J($$COM(APCRTOT,0),8)
  1. W !," Total Number of Patients Screened",?40,$J($$COM(APCRPTOT,0),8)
  1. D LIST
  1. Q
  1. COM(X,X2,X3) ;
  1. D COMMA^%DTC
  1. Q $$STRIP^XLFSTR(X," ")
  1. END() ;
  1. I $Y<(IOSL-3) Q 0
  1. D HEADER
  1. I $D(APCRQUIT) Q 1
  1. Q 0
  1. ENDL() ;
  1. I $Y<(IOSL-8) Q 0
  1. D HEADER
  1. I $D(APCRQUIT) Q 1
  1. Q 0
  1. PTOT() ;
  1. NEW C,X
  1. S C=0
  1. S X=0 F S X=$O(^XTMP("APCLAL3",APCRJ,APCRH,"PTS",X)) Q:X'=+X S C=C+1
  1. Q C
  1. TOT() ;
  1. NEW C,X
  1. S C=0
  1. S X=0 F S X=$O(^XTMP("APCLAL3",APCRJ,APCRH,"VSTS",X)) Q:X'=+X S C=C+1
  1. Q C
  1. G:'APCRPG HEADER1
  1. 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 APCRQUIT="" Q
  1. HEADER1 ;
  1. W:$D(IOF) @IOF S APCRPG=APCRPG+1
  1. W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCRPG,!
  1. W !,$$CTR("*** ALCOHOL SCREENING VISIT LISTING FOR SELECTED PATIENTS ***",80),!
  1. S X="Screening Dates: "_$$FMTE^XLFDT(APCRBD)_" to "_$$FMTE^XLFDT(APCRED) W $$CTR(X,80),!
  1. W !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?55,"CLINIC"
  1. W !,$TR($J("",80)," ","-")
  1. Q
  1. DONE ;
  1. K ^TMP($J)
  1. K ^XTMP("APCLAL3",APCRJ,APCRH)
  1. D EOP
  1. Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1. Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1. ;----------
  1. EOP ;EP - End of page.
  1. Q:$E(IOST)'="C"
  1. Q:IO'=IO(0)
  1. Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1. NEW DIR
  1. K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1. W !
  1. S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
  1. Q
  1. ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1. Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1. ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1. Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1. ;----------
  1. LIST ;EP - called from xbdbque
  1. S APCRPG=0 K APCRQUIT
  1. S APCRLSTP=1
  1. D HEADER
  1. K ^TMP($J)
  1. ;resort by sort item
  1. S APCRX=0 F S APCRX=$O(^XTMP("APCLAL3",APCRJ,APCRH,"PTS",APCRX)) Q:APCRX'=+APCRX S APCRY=^XTMP("APCLAL3",APCRJ,APCRH,"PTS",APCRX) D
  1. .S DFN=APCRX
  1. .D @APCRSORT
  1. .I APCRSORV="" S APCRSORV="--"
  1. .S ^TMP($J,"PTS",APCRSORV,APCRX)=APCRY
  1. .Q
  1. S APCRSORV="" F S APCRSORV=$O(^TMP($J,"PTS",APCRSORV)) Q:APCRSORV=""!($D(APCRQUIT)) D
  1. .S DFN=0 F S DFN=$O(^TMP($J,"PTS",APCRSORV,DFN)) Q:DFN'=+DFN!($D(APCRQUIT)) D
  1. ..Q:$$ENDL
  1. ..S APCRY=^TMP($J,"PTS",APCRSORV,DFN)
  1. ..W !!,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$P(APCRY,U,4),?33,$P(^DPT(DFN,0),U,2),?35,$$DT($P(APCRY,U,1)),?55,$E($P(APCRY,U,6),1,20)
  1. ..W !?3,"Type/Result: ",$P($P(APCRY,U,2),";")_" "_$P($P(APCRY,U,2),";",2)
  1. ..I $P(APCRY,U,12)]"" W !?3,"Comment: ",$P(APCRY,U,12)
  1. ..I $P(APCRY,U,20)="PCC" S APCRV=$P(APCRY,U,14) I APCRV,$D(^AUPNVPOV("AD",APCRV)) D
  1. ...S APCRC=0 W !?3,"DXs: "
  1. ...S APCRX=0 F S APCRX=$O(^AUPNVPOV("AD",APCRV,APCRX)) Q:APCRX'=+APCRX!($D(APCRQUIT)) D
  1. ....S APCRC=APCRC+1
  1. ....W:APCRC'=1 ! W ?8,$$VAL^XBDIQ1(9000010.07,APCRX,.01),?17,$E($$VAL^XBDIQ1(9000010.07,APCRX,.04),1,60)
  1. ..I $P(APCRY,U,20)="BH" S APCRV=$P(APCRY,U,15) I APCRV,$D(^AMHRPRO("AD",APCRV)) D
  1. ...S APCRC=0 W !?3,"DXs: "
  1. ...S APCRX=0 F S APCRX=$O(^AMHRPRO("AD",APCRV,APCRX)) Q:APCRX'=+APCRX!($D(APCRQUIT)) D
  1. ....S APCRC=APCRC+1
  1. ....W:APCRC'=1 ! W ?8,$$VAL^XBDIQ1(9002011.01,APCRX,.01),?17,$E($$VAL^XBDIQ1(9002011.01,APCRX,.04),1,60)
  1. ..W !?3,"Primary Provider on Visit: ",?31,$P(APCRY,U,7)
  1. ..W !?3," Provider who screened: ",?31,$P(APCRY,U,5)
  1. Q
  1. H ;
  1. S APCRSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
  1. Q
  1. N ;
  1. S APCRSORV=$P(^DPT(DFN,0),U)
  1. Q
  1. P ;
  1. S APCRSORV=$P(APCRY,U,5)
  1. Q
  1. R ;
  1. S APCRSORV=$P($P(APCRY,U,2),";")_" "_$P($P(APCRY,U,2),";",2)
  1. Q
  1. D ;
  1. S APCRSORV=$P(APCRY,U,1)
  1. Q
  1. A S APCRSORV=$P(APCRY,U,4)
  1. Q
  1. G ;
  1. S APCRSORV=$P(APCRY,U,3)
  1. Q
  1. C ;
  1. S APCRSORV=$P(APCRY,U,6)
  1. Q
  1. T ;
  1. S %=$$HRN^AUPNPAT(DFN,DUZ(2))
  1. S %=%+10000000,%=$E(%,7,8)_"-"_+$E(%,2,8)
  1. S APCRSORV=%
  1. Q
  1. DT(D) ;EP
  1. I D="" Q ""
  1. Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1. ;
  1. COVPAGE ;EP
  1. W:$D(IOF) @IOF
  1. W !,$$CTR("********** ALCOHOL SCREENING FOR SELECTED PATIENTS **********",80)
  1. W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U)
  1. W !!,"The following report contains an ALCOHOL screening report based on the",!,"following criteria:"
  1. SHOW ;
  1. W !!?6,"Patient must have had a screening between ",$$FMTE^XLFDT(APCRBD)," and ",$$FMTE^XLFDT(APCRED),!
  1. ;W:APCRTYPE="S" !!?6,"Search Template: ",$P(^DIBT(APCRSEAT,0),U),!
  1. W !?6,"Gender: ",$S(APCRSEX="F":"FEMALES ONLY",APCRSEX="M":"MALES ONLY",APCRSEX="U":"UNKNOWN",APCRSEX="MFU":"ALL GENDERS",1:"")
  1. I $D(APCRAGET) W !?6,"Age of Patients included: ",$P(APCRAGET,"-")," to ",$P(APCRAGET,"-",2)
  1. I '$D(APCRAGET) W !?6,"All Ages included"
  1. W !?6,"Patients must have had a screening during the time period with one of ",!?6,"the following screening results:"
  1. W ! S X="" F S X=$O(APCRREST(X)) Q:X'=+X D
  1. .I X=1 W ?8,"NEGATIVE"
  1. .I X=2 W " ","POSITIVE"
  1. .I X=3 W " ","REFUSED"
  1. .I X=4 W " ","UNABLE TO SCREEN"
  1. .I X=5 W !?8,"SCREENINGS WITH NO RECORDED RESULT"
  1. I $D(APCRCLNT) W !,"Screenings done in the following clinics are included:" D
  1. .S X=0 F S X=$O(APCRCLNT(X)) Q:X'=+X W !?10,$P(^DIC(40.7,X,0),U)," ("_$P(^DIC(40.7,X,0),U,2)_")"
  1. I '$D(APCRCLNT),APCLEXBH W !,"Screenings done in ALL clinics included"
  1. I 'APCLEXBH W !,"Behavioral Health Clinics excluded."
  1. I APCRDESP]"" W !,"Only patients whose Designated Mental Health Provider",!?6,$P(^VA(200,APCRDESP,0),U)," are included"
  1. I APCRSSP]"" W !,"Only patients whose Designated Social Services Provider",!?6,$P(^VA(200,APCRSSP,0),U)," are included"
  1. I APCRCDP]"" W !,"Only patients whose Designated ASA/CD Provider",!?6,$P(^VA(200,APCRCDP,0),U)," are included"
  1. I APCRPPUN W !,"Only patients who had a visit on which a screeening was done",!?6,"but the primary provider on the visit was UNKNOWN are included."
  1. I APCRSPUN W !,"Only patients who had a visit on which a screeening was done",!?6,"but the screening provider on the visit was UNKNOWN are included."
  1. I '$D(APCRPROV) W !,"Visits to any Primary Provider are included"
  1. I '$D(APCRSPRV) W !,"Visits on which any provider did the screening are included"
  1. I $D(APCRPROV) W !,"Only screenings on which ",$P(^VA(200,APCRPROV,0),U)," was the primary provider",!?6,"on the visit are included"
  1. I $D(APCRSPRV) W !,"Only screenings on which ",$P(^VA(200,APCRSPRV,0),U)," was the primary provider",!?6,"on the visit are included"
  1. D PAUSE
  1. Q
  1. PAUSE ;
  1. Q:$E(IOST)'="C"
  1. Q:IO'=IO(0)
  1. S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA
  1. S:$D(DIRUT) APCRQUIT=1
  1. W:$D(IOF) @IOF
  1. Q