VENPCC1E ; IHS/OIT/GIS - NEW HEALTH MAINTENANCE REMINDER OUTOPUT ;
;;2.6;PCC+;;NOV 12, 2007
;
; INCLUDES NEW CODE FOR PATIENT REFUSALS IN VER 2.5
;
RAW(APCHSPAT,APCHSTYP) ; EP-GET RAW HMR TEXT
N APCHSCVD,APCHSBRK,APCHSCKP,APCHSNPG,APCHSBWR,APCHSERR,DDH,%T,%Y,AMQQTAXN,E
S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S APCHSBRK="",APCHSCKP="",APCHSNPG=1
D SURV^APCHS11
Q
;
LINE ; EP-INC LINE
N I,X S I=0
F R X:30 Q:$$STATUS^%ZISH!(X["** END ") D
. I X="" Q
. I X["LAST",X["NEXT" Q
. S I=I+1,@TMP@(I)=X
. Q
Q
;
ARR(DFN) ; EP-SAVE SURVEILANNCE INFO IN A TMP ARRAY
N PATH,TMP,IOST,IOSL,IOM,POP,HSIEN,AGE,%,LINE,FILE
I '$D(^DPT(+$G(DFN,0),0)) Q
S %=+$P($G(^DPT(DFN,0)),U,3) I '% Q
S AGE=(DT-%)\10000
S HSIEN=$O(^APCHSCTL("B",$S(AGE<12:"PEDIATRIC",1:"ADULT REGULAR"),0)) I '$G(HSIEN) Q
S PATH=$G(^VEN(7.5,+$$CFG^VENPCCU,3)) I '$L(PATH) Q
S TMP="^TMP(""VEN SURV"",$J)",FILE="S"_DFN_".TXT" K @TMP
S IOST="P-PRINTER",IOSL=99999,IOM=80
S POP=$$OPN^VENPCCP(PATH,FILE,"W","N IO S IO=DEV D RAW^VENPCC1E(DFN,HSIEN)") I POP Q
S POP=$$OPN^VENPCCP(PATH,FILE,"R","D LINE^VENPCC1E") I POP Q
D DEL^VENPCCP1(PATH,("S"_DFN_".TXT")) ; CLEAN UP THE TMP FILE
D ITEM(DFN) ; GETS NEW SURVEILLANCE ITEMS (h26-h50) AND CLEARS OUT OLD ITEMS (h1-h8)
I $G(DEFEF) D REF(DFN,DEFEF) ; PATIENT REFUSALS
K @TMP
Q
;
CREF(FILE) ; EP-GIVEN A V FILE NUMBER, RETURN THE CLOSED REF
N X
S X=$G(^DIC(FILE,0,"GL")) I X="" Q X
I $E($RE(X),1)="(" S X=$TR(X,"(","")
E S X=$RE(X) S $E(X,1)=")" S X=$RE(X)
Q X
;
EXDT(DATE,A) ; EP-EXTERNAL DATE TO INTERNAL FM FORMAT. IF A=1, RETURN DAY ONLY
N X,Y,%DT
S X=DATE,%DT="P"
D ^%DT
I Y=-1 Q ""
I A S Y=Y\1
Q Y
;
LAST(DFN,TYPE,DATE) ; EP-RETURN THE LAST VALUE FOR A PATIENT ON A GIVEN DATE
I $G(DFN),$L($G(DATE)),$L(TYPE)
E Q ""
N SIEN,FILE,VFILE,LUV,LIEN,%,X,OREF,SDATE,IDATE,DIC,Y,UNITS,TIEN,PCE,CREF,DDH,LDT,%DT,VIEN,RES,SPEC
S %=$O(^APCHSURV("B",TYPE,0)) I '$D(^VEN(7.96,+%,0)),TYPE'="PRIME MD SCORE" Q "" ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
S SIEN=$O(^APCHSURV("B",TYPE,0)) I 'SIEN Q ""
S %=$G(^VEN(7.96,SIEN,0)),FILE=$P(%,U,2),VFILE=$P(%,U,3),UNITS=$P(%,U,4),SPEC=$G(^VEN(7.96,SIEN,2))
I $L(FILE),$L(VFILE)
E Q ""
S LDT=$$EXDT(DATE,1) I 'LDT Q ""
S IDATE=9999999-LDT
I $L(SPEC) X ("S X=$$"_SPEC_"(DFN,IDATE)") Q X
S LUV="",LIEN=0,DIC(0)="MX",DIC=$G(^DIC(FILE,0,"GL")) I '$L(DIC) Q ""
F S LIEN=$O(^VEN(7.96,SIEN,1,LIEN)) Q:'LIEN D
. S X=$G(^VEN(7.96,SIEN,1,LIEN,0)) I '$L(X) Q
. D ^DIC I Y=-1 Q
. I $L(LUV) S LUV=LUV_U
. S LUV=LUV_(+Y)
. Q
I '$L(LUV) Q ""
S CREF=$$CREF(VFILE) I '$L(CREF) Q ""
F PCE=1:1:$L(LUV,U) S TIEN=$P(LUV,U,PCE) I TIEN D I $L($G(VAL)) Q
. S VIEN=999999999 F S VIEN=$O(@CREF@("AA",DFN,TIEN,IDATE,VIEN),-1) Q:'VIEN D I $L($G(VAL)) Q
.. K VAL
.. I VFILE=9000010.09 D Q
... S VAL=$P($G(^AUPNVLAB(VIEN,0)),U,4),RES=$P($G(^AUPNVLAB(VIEN,0)),U,5)
... I TYPE="PAP SMEAR",$G(VAL) S VAL="Class "_VAL
... I $L(VAL),$L($G(UNITS)) S VAL=VAL_UNITS
... I $L(VAL),$L(RES) S VAL=VAL_" "
... I $L(RES) S VAL=VAL_"("_RES_")"
... I '$L(VAL) K VAL
... Q
.. I VFILE=9000010.12 D Q
... S VAL=$P($G(^AUPNVSK(VIEN,0)),U,4),X=$P($G(^AUPNVSK(VIEN,0)),U,5)
... S RES=$S(X="P":"Pos",X="N":"Neg",X="D":"Doubtful",X="0":"No take",1:"")
... I $L(VAL),$L(RES) S VAL=VAL_" "
... I $L(RES) S VAL=VAL_"("_RES_")"
... I '$L(VAL) K VAL
... Q
.. I VFILE=9000010.13 D Q
... S VAL=$P($G(^AUPNVXAM(VIEN,0)),U,4)
... I '$L(VAL) K VAL Q
... S VAL=$S(VAL="N":"Nl",VAL="A":"Abnl",1:VAL)
... Q
.. Q
. I '$L($G(VAL)),$D(^AUPNPREF("AA",DFN,FILE,TIEN,IDATE)) S VAL="REFUSED!" Q
. Q
Q $G(VAL)
;
ITEM(DFN) ; EP-GET EACH ITEM AND STORE RESULTS
N LINE,STG,X,TYPE,FORC,VAL,Y,DATE,CNT,%,I,TMP,GBL
S TMP=$NA(^TMP("VEN PRNT",$J,1))
S GBL=$NA(^TMP("VEN SURV",$J))
F I=1:1:8 S @TMP@("h"_I)="" ; CLEAR OLD SURVEILLANCE ITEMS ; PATCHED BY GIS 1/15/04
S LINE=0,CNT=25
F S LINE=$O(@GBL@(LINE)) Q:'LINE D
. S STG=$G(@GBL@(LINE)) I '$L(STG) Q
. S X=$E(STG,1,23),TYPE=$$STRIP(X) I '$L(TYPE) Q
. ; S %=$O(^APCHSURV("B",TYPE,0)) I '$D(^VEN(7.96,+%,0)),TYPE'="PRIME MD SCORE" Q ; ITEM MUST EXIST IN VEN SURV FILE ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
. S X=$E(STG,24,36) S DATE=$$STRIP(X)
. I DATE?1." "2N1"/"2N1"/"2N S DATE=$TR(DATE," ","") ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
. S X=$E(STG,37,99),FORC=$$STRIP(X)
. I FORC?2N1"/"2N1"/"2N S FORC="Due: "_FORC ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
. S VAL=$$LAST(DFN,TYPE,DATE),CNT=CNT+1 I CNT>50 Q
. S STG=TYPE I $L(DATE) S STG=STG_" Last: "_DATE
. I $L(VAL) S STG=STG_" "_VAL ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
. I $L(FORC) S STG=STG_" "_FORC ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
. S @TMP@("h"_CNT)=STG
. Q
Q
;
STRIP(X) ; EP-STRIP BLANKS OFF THE END
N I,Y
S X=$RE(X)
F I=1:1 S Y=$E(X,I) Q:Y'=" "
Q $RE($E(X,I,999))
;
MAMMO(DFN,IDATE) ; EP-GIVEN A DFN, RETURN THE LAST MAMMOGRAM h4
N %,X,PIEN,VAL,STOP
S PIEN=$O(^APCHSURV("B","MAMMOGRAM",0)) I 'PIEN Q "Unknown"
I $L($T(INAC^APCHSMU)),$$INAC^APCHSMU(%),$O(^BWPCD(0))
E Q ""
S IDATE=0,STOP=""
S PIEN=0 F S PIEN=$O(^BWPCD("AA",DFN,IDATE,PIEN)) Q:'PIEN D I STOP Q
. S %=$P($G(^BWPCD(PIEN,0)),U,4)
. I %'=25,%'=26,%'=28 Q
. S STOP=PIEN
. Q
I 'STOP Q "Unknown"
S VAL=$P($G(^BWPCD(STOP,0)),U,5)
I '$L(VAL) Q "Unknown"
Q VAL
;
REF(DFN,DEFEF) ; EP - PATIENT REFUSALS (h1 - h8)
I '$O(^AUPNPREF("AA",+$G(DFN),0)) Q ; NO REFUSALS SO QUIT
N MAXDT,PTED,FILE,FIEN,IDT,MOS,RIEN,X,STG,CNT,TOT,DAYS,MIDT,DATE,VIEN,WHAT,%,TMP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
S STG=$G(^VEN(7.41,DEFEF,15))
S MOS=$P(STG,U) I MOS=0 Q ; REFUSALS HAS BEEN TURNED OFF
I MOS="" S MOS=60
S DAYS=(MOS*30.5)\1
S MIDT=9999999-$$FMADD^XLFDT(DT,-DAYS,"","","")
S PTED=+$P(STG,U,2)
S FILE=0,CNT=0
F S FILE=$O(^AUPNPREF("AA",DFN,FILE)) Q:'FILE D
. I 'PTED,FILE=9999999.09 Q ; PATIENT ED REFUSALS SHOULD BE EXCLUDED
. S FIEN=0 F S FIEN=$O(^AUPNPREF("AA",DFN,FILE,FIEN)) Q:'FIEN D I CNT=8 Q
.. S IDT=0 F Q:IDT>MIDT S IDT=$O(^AUPNPREF("AA",DFN,FILE,FIEN,IDT)) Q:'IDT D I CNT=8 Q
... S RIEN=0 F S RIEN=$O(^AUPNPREF("AA",DFN,FILE,FIEN,IDT,RIEN)) Q:'RIEN D I CNT=8 Q
.... S X=$G(^AUPNPREF(RIEN,0)) I '$L(X) Q
.... S WHAT=$P(X,U,4)
.... S %=$P(X,U,3) I '% Q
.... S DATE=$$FMTE^XLFDT(%,"2D")
.... S CNT=CNT+1
.... S @TMP@("h"_CNT)="Refused "_WHAT_" ("_DATE_")"
.... Q
... Q
.. Q
. Q
Q
VENPCC1E ; IHS/OIT/GIS - NEW HEALTH MAINTENANCE REMINDER OUTOPUT ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ; INCLUDES NEW CODE FOR PATIENT REFUSALS IN VER 2.5
+4 ;
RAW(APCHSPAT,APCHSTYP) ; EP-GET RAW HMR TEXT
+1 NEW APCHSCVD,APCHSBRK,APCHSCKP,APCHSNPG,APCHSBWR,APCHSERR,DDH,%T,%Y,AMQQTAXN,E
+2 SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+3 SET APCHSBRK=""
SET APCHSCKP=""
SET APCHSNPG=1
+4 DO SURV^APCHS11
+5 QUIT
+6 ;
LINE ; EP-INC LINE
+1 NEW I,X
SET I=0
+2 FOR
READ X:30
IF $$STATUS^%ZISH!(X["** END ")
QUIT
Begin DoDot:1
+3 IF X=""
QUIT
+4 IF X["LAST"
IF X["NEXT"
QUIT
+5 SET I=I+1
SET @TMP@(I)=X
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
ARR(DFN) ; EP-SAVE SURVEILANNCE INFO IN A TMP ARRAY
+1 NEW PATH,TMP,IOST,IOSL,IOM,POP,HSIEN,AGE,%,LINE,FILE
+2 IF '$DATA(^DPT(+$GET(DFN,0),0))
QUIT
+3 SET %=+$PIECE($GET(^DPT(DFN,0)),U,3)
IF '%
QUIT
+4 SET AGE=(DT-%)\10000
+5 SET HSIEN=$ORDER(^APCHSCTL("B",$SELECT(AGE<12:"PEDIATRIC",1:"ADULT REGULAR"),0))
IF '$GET(HSIEN)
QUIT
+6 SET PATH=$GET(^VEN(7.5,+$$CFG^VENPCCU,3))
IF '$LENGTH(PATH)
QUIT
+7 SET TMP="^TMP(""VEN SURV"",$J)"
SET FILE="S"_DFN_".TXT"
KILL @TMP
+8 SET IOST="P-PRINTER"
SET IOSL=99999
SET IOM=80
+9 SET POP=$$OPN^VENPCCP(PATH,FILE,"W","N IO S IO=DEV D RAW^VENPCC1E(DFN,HSIEN)")
IF POP
QUIT
+10 SET POP=$$OPN^VENPCCP(PATH,FILE,"R","D LINE^VENPCC1E")
IF POP
QUIT
+11 ; CLEAN UP THE TMP FILE
DO DEL^VENPCCP1(PATH,("S"_DFN_".TXT"))
+12 ; GETS NEW SURVEILLANCE ITEMS (h26-h50) AND CLEARS OUT OLD ITEMS (h1-h8)
DO ITEM(DFN)
+13 ; PATIENT REFUSALS
IF $GET(DEFEF)
DO REF(DFN,DEFEF)
+14 KILL @TMP
+15 QUIT
+16 ;
CREF(FILE) ; EP-GIVEN A V FILE NUMBER, RETURN THE CLOSED REF
+1 NEW X
+2 SET X=$GET(^DIC(FILE,0,"GL"))
IF X=""
QUIT X
+3 IF $EXTRACT($REVERSE(X),1)="("
SET X=$TRANSLATE(X,"(","")
+4 IF '$TEST
SET X=$REVERSE(X)
SET $EXTRACT(X,1)=")"
SET X=$REVERSE(X)
+5 QUIT X
+6 ;
EXDT(DATE,A) ; EP-EXTERNAL DATE TO INTERNAL FM FORMAT. IF A=1, RETURN DAY ONLY
+1 NEW X,Y,%DT
+2 SET X=DATE
SET %DT="P"
+3 DO ^%DT
+4 IF Y=-1
QUIT ""
+5 IF A
SET Y=Y\1
+6 QUIT Y
+7 ;
LAST(DFN,TYPE,DATE) ; EP-RETURN THE LAST VALUE FOR A PATIENT ON A GIVEN DATE
+1 IF $GET(DFN)
IF $LENGTH($GET(DATE))
IF $LENGTH(TYPE)
+2 IF '$TEST
QUIT ""
+3 NEW SIEN,FILE,VFILE,LUV,LIEN,%,X,OREF,SDATE,IDATE,DIC,Y,UNITS,TIEN,PCE,CREF,DDH,LDT,%DT,VIEN,RES,SPEC
+4 ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
SET %=$ORDER(^APCHSURV("B",TYPE,0))
IF '$DATA(^VEN(7.96,+%,0))
IF TYPE'="PRIME MD SCORE"
QUIT ""
+5 SET SIEN=$ORDER(^APCHSURV("B",TYPE,0))
IF 'SIEN
QUIT ""
+6 SET %=$GET(^VEN(7.96,SIEN,0))
SET FILE=$PIECE(%,U,2)
SET VFILE=$PIECE(%,U,3)
SET UNITS=$PIECE(%,U,4)
SET SPEC=$GET(^VEN(7.96,SIEN,2))
+7 IF $LENGTH(FILE)
IF $LENGTH(VFILE)
+8 IF '$TEST
QUIT ""
+9 SET LDT=$$EXDT(DATE,1)
IF 'LDT
QUIT ""
+10 SET IDATE=9999999-LDT
+11 IF $LENGTH(SPEC)
XECUTE ("S X=$$"_SPEC_"(DFN,IDATE)")
QUIT X
+12 SET LUV=""
SET LIEN=0
SET DIC(0)="MX"
SET DIC=$GET(^DIC(FILE,0,"GL"))
IF '$LENGTH(DIC)
QUIT ""
+13 FOR
SET LIEN=$ORDER(^VEN(7.96,SIEN,1,LIEN))
IF 'LIEN
QUIT
Begin DoDot:1
+14 SET X=$GET(^VEN(7.96,SIEN,1,LIEN,0))
IF '$LENGTH(X)
QUIT
+15 DO ^DIC
IF Y=-1
QUIT
+16 IF $LENGTH(LUV)
SET LUV=LUV_U
+17 SET LUV=LUV_(+Y)
+18 QUIT
End DoDot:1
+19 IF '$LENGTH(LUV)
QUIT ""
+20 SET CREF=$$CREF(VFILE)
IF '$LENGTH(CREF)
QUIT ""
+21 FOR PCE=1:1:$LENGTH(LUV,U)
SET TIEN=$PIECE(LUV,U,PCE)
IF TIEN
Begin DoDot:1
+22 SET VIEN=999999999
FOR
SET VIEN=$ORDER(@CREF@("AA",DFN,TIEN,IDATE,VIEN),-1)
IF 'VIEN
QUIT
Begin DoDot:2
+23 KILL VAL
+24 IF VFILE=9000010.09
Begin DoDot:3
+25 SET VAL=$PIECE($GET(^AUPNVLAB(VIEN,0)),U,4)
SET RES=$PIECE($GET(^AUPNVLAB(VIEN,0)),U,5)
+26 IF TYPE="PAP SMEAR"
IF $GET(VAL)
SET VAL="Class "_VAL
+27 IF $LENGTH(VAL)
IF $LENGTH($GET(UNITS))
SET VAL=VAL_UNITS
+28 IF $LENGTH(VAL)
IF $LENGTH(RES)
SET VAL=VAL_" "
+29 IF $LENGTH(RES)
SET VAL=VAL_"("_RES_")"
+30 IF '$LENGTH(VAL)
KILL VAL
+31 QUIT
End DoDot:3
QUIT
+32 IF VFILE=9000010.12
Begin DoDot:3
+33 SET VAL=$PIECE($GET(^AUPNVSK(VIEN,0)),U,4)
SET X=$PIECE($GET(^AUPNVSK(VIEN,0)),U,5)
+34 SET RES=$SELECT(X="P":"Pos",X="N":"Neg",X="D":"Doubtful",X="0":"No take",1:"")
+35 IF $LENGTH(VAL)
IF $LENGTH(RES)
SET VAL=VAL_" "
+36 IF $LENGTH(RES)
SET VAL=VAL_"("_RES_")"
+37 IF '$LENGTH(VAL)
KILL VAL
+38 QUIT
End DoDot:3
QUIT
+39 IF VFILE=9000010.13
Begin DoDot:3
+40 SET VAL=$PIECE($GET(^AUPNVXAM(VIEN,0)),U,4)
+41 IF '$LENGTH(VAL)
KILL VAL
QUIT
+42 SET VAL=$SELECT(VAL="N":"Nl",VAL="A":"Abnl",1:VAL)
+43 QUIT
End DoDot:3
QUIT
+44 QUIT
End DoDot:2
IF $LENGTH($GET(VAL))
QUIT
+45 IF '$LENGTH($GET(VAL))
IF $DATA(^AUPNPREF("AA",DFN,FILE,TIEN,IDATE))
SET VAL="REFUSED!"
QUIT
+46 QUIT
End DoDot:1
IF $LENGTH($GET(VAL))
QUIT
+47 QUIT $GET(VAL)
+48 ;
ITEM(DFN) ; EP-GET EACH ITEM AND STORE RESULTS
+1 NEW LINE,STG,X,TYPE,FORC,VAL,Y,DATE,CNT,%,I,TMP,GBL
+2 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 SET GBL=$NAME(^TMP("VEN SURV",$JOB))
+4 ; CLEAR OLD SURVEILLANCE ITEMS ; PATCHED BY GIS 1/15/04
FOR I=1:1:8
SET @TMP@("h"_I)=""
+5 SET LINE=0
SET CNT=25
+6 FOR
SET LINE=$ORDER(@GBL@(LINE))
IF 'LINE
QUIT
Begin DoDot:1
+7 SET STG=$GET(@GBL@(LINE))
IF '$LENGTH(STG)
QUIT
+8 SET X=$EXTRACT(STG,1,23)
SET TYPE=$$STRIP(X)
IF '$LENGTH(TYPE)
QUIT
+9 ; S %=$O(^APCHSURV("B",TYPE,0)) I '$D(^VEN(7.96,+%,0)),TYPE'="PRIME MD SCORE" Q ; ITEM MUST EXIST IN VEN SURV FILE ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
+10 SET X=$EXTRACT(STG,24,36)
SET DATE=$$STRIP(X)
+11 ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
IF DATE?1." "2N1"/"2N1"/"2N
SET DATE=$TRANSLATE(DATE," ","")
+12 SET X=$EXTRACT(STG,37,99)
SET FORC=$$STRIP(X)
+13 ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
IF FORC?2N1"/"2N1"/"2N
SET FORC="Due: "_FORC
+14 SET VAL=$$LAST(DFN,TYPE,DATE)
SET CNT=CNT+1
IF CNT>50
QUIT
+15 SET STG=TYPE
IF $LENGTH(DATE)
SET STG=STG_" Last: "_DATE
+16 ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
IF $LENGTH(VAL)
SET STG=STG_" "_VAL
+17 ; PATCHED BY GIS/OIT 2/25/06 ; PCC+ 2.5 PATCH 3
IF $LENGTH(FORC)
SET STG=STG_" "_FORC
+18 SET @TMP@("h"_CNT)=STG
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
STRIP(X) ; EP-STRIP BLANKS OFF THE END
+1 NEW I,Y
+2 SET X=$REVERSE(X)
+3 FOR I=1:1
SET Y=$EXTRACT(X,I)
IF Y'=" "
QUIT
+4 QUIT $REVERSE($EXTRACT(X,I,999))
+5 ;
MAMMO(DFN,IDATE) ; EP-GIVEN A DFN, RETURN THE LAST MAMMOGRAM h4
+1 NEW %,X,PIEN,VAL,STOP
+2 SET PIEN=$ORDER(^APCHSURV("B","MAMMOGRAM",0))
IF 'PIEN
QUIT "Unknown"
+3 IF $LENGTH($TEXT(INAC^APCHSMU))
IF $$INAC^APCHSMU(%)
IF $ORDER(^BWPCD(0))
+4 IF '$TEST
QUIT ""
+5 SET IDATE=0
SET STOP=""
+6 SET PIEN=0
FOR
SET PIEN=$ORDER(^BWPCD("AA",DFN,IDATE,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+7 SET %=$PIECE($GET(^BWPCD(PIEN,0)),U,4)
+8 IF %'=25
IF %'=26
IF %'=28
QUIT
+9 SET STOP=PIEN
+10 QUIT
End DoDot:1
IF STOP
QUIT
+11 IF 'STOP
QUIT "Unknown"
+12 SET VAL=$PIECE($GET(^BWPCD(STOP,0)),U,5)
+13 IF '$LENGTH(VAL)
QUIT "Unknown"
+14 QUIT VAL
+15 ;
REF(DFN,DEFEF) ; EP - PATIENT REFUSALS (h1 - h8)
+1 ; NO REFUSALS SO QUIT
IF '$ORDER(^AUPNPREF("AA",+$GET(DFN),0))
QUIT
+2 NEW MAXDT,PTED,FILE,FIEN,IDT,MOS,RIEN,X,STG,CNT,TOT,DAYS,MIDT,DATE,VIEN,WHAT,%,TMP
+3 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+4 SET STG=$GET(^VEN(7.41,DEFEF,15))
+5 ; REFUSALS HAS BEEN TURNED OFF
SET MOS=$PIECE(STG,U)
IF MOS=0
QUIT
+6 IF MOS=""
SET MOS=60
+7 SET DAYS=(MOS*30.5)\1
+8 SET MIDT=9999999-$$FMADD^XLFDT(DT,-DAYS,"","","")
+9 SET PTED=+$PIECE(STG,U,2)
+10 SET FILE=0
SET CNT=0
+11 FOR
SET FILE=$ORDER(^AUPNPREF("AA",DFN,FILE))
IF 'FILE
QUIT
Begin DoDot:1
+12 ; PATIENT ED REFUSALS SHOULD BE EXCLUDED
IF 'PTED
IF FILE=9999999.09
QUIT
+13 SET FIEN=0
FOR
SET FIEN=$ORDER(^AUPNPREF("AA",DFN,FILE,FIEN))
IF 'FIEN
QUIT
Begin DoDot:2
+14 SET IDT=0
FOR
IF IDT>MIDT
QUIT
SET IDT=$ORDER(^AUPNPREF("AA",DFN,FILE,FIEN,IDT))
IF 'IDT
QUIT
Begin DoDot:3
+15 SET RIEN=0
FOR
SET RIEN=$ORDER(^AUPNPREF("AA",DFN,FILE,FIEN,IDT,RIEN))
IF 'RIEN
QUIT
Begin DoDot:4
+16 SET X=$GET(^AUPNPREF(RIEN,0))
IF '$LENGTH(X)
QUIT
+17 SET WHAT=$PIECE(X,U,4)
+18 SET %=$PIECE(X,U,3)
IF '%
QUIT
+19 SET DATE=$$FMTE^XLFDT(%,"2D")
+20 SET CNT=CNT+1
+21 SET @TMP@("h"_CNT)="Refused "_WHAT_" ("_DATE_")"
+22 QUIT
End DoDot:4
IF CNT=8
QUIT
+23 QUIT
End DoDot:3
IF CNT=8
QUIT
+24 QUIT
End DoDot:2
IF CNT=8
QUIT
+25 QUIT
End DoDot:1
+26 QUIT
