ABSPOS34 ; IHS/FCS/DRS - survey elig. status ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
Q
MAIN ;EP - option: ABSP BEN/ELIG SURVEY
W !!,"Survey BENEFICIARY/ELIGIBILITY status from recent prescriptions",!
N X1,X2,X,%H ;S X1=DT,X2=-60 D C^%DTC ; X = result
S X=DT-10000 ; 1 year ago
N START,END
S START=$$DATE^ABSPOSU1("Start date: ",X,1,2970000,4000000,"E",300)
Q:'START S END=DT
N POP D ^%ZIS Q:$G(POP)
U $P W !,"...thinking...",!
D MAIN1(START)
D ^%ZISC
Q
HEADING ;
W @IOF
W "Survey of Beneficiary/Eligibility Status (","ABSPOS34",")",?60,RPTDATE,!
W "For " N Y S Y=START X ^DD("DD") W Y
I START'=END S Y=END X ^DD("DD") W "-",Y,!
W ?3,"Count",?10,"Status",!
Q
MAIN1(START) ; START = fileman date.time to start search
; Build ^TMP("ABSPOS34",$J,ien)=count^name
; ^TMP("ABSPOS34",$J,"B",count)=INSIEN
N RPTDATE S RPTDATE=$$NOWEXT^ABSPOSU1
DO SURVEY(START)
I '$D(^TMP("ABSPOS34",$J)) W !,"No prescriptions found?!",! Q
U IO D HEADING
N COUNT,INS,NUMBERS,X
S COUNT="" F S COUNT=$O(^TMP("ABSPOS34",$J,"B",COUNT),-1) Q:'COUNT D
. S INS=0 F S INS=$O(^TMP("ABSPOS34",$J,"B",COUNT,INS)) Q:INS="" D
. . S X=^TMP("ABSPOS34",$J,INS)
. . W $J(COUNT,7),?10,$E($P(X,U,2),1,40)
. . I $P(X,U,3)]"" W ?51,$P(X,U,3)
. . W !
. . I $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$T(+0)) S INS=99999999,COUNT=1
D ENDRPT^ABSPOSU5()
Q
SURVEY(START) ; START = fileman date.time
N RXI,RXR,DOC,TIME S TIME=START K ^TMP("ABSPOS34",$J)
F D S TIME=$O(^PSRX("AL",TIME)) Q:'TIME
. S RXI="" F S RXI=$O(^PSRX("AL",TIME,RXI)) Q:'RXI D
. . S RXR="" F S RXR=$O(^PSRX("AL",TIME,RXI,RXR)) Q:RXR="" D
. . . D SURVEY1
; Now index it by count
S DOC=""
F S DOC=$O(^TMP("ABSPOS34",$J,DOC)) Q:DOC="" I "B"'[DOC D
. N X S X=^TMP("ABSPOS34",$J,DOC) N COUNT S COUNT=$P(X,U)
. S ^TMP("ABSPOS34",$J,"B",COUNT,DOC)=""
Q
SURVEY1 ; given RXI, RXR
N NAME,P1112,PAT
S PAT=$P($G(^PSRX(RXI,0)),U,2)
I PAT D
. S P1112=$P($G(^AUPNPAT(PAT,11)),U,11,12)
. I P1112?."^" S (NAME,P1112)="???"
. E D
. . N BEN,ELG S BEN=$P(P1112,U),ELG=$P(P1112,U,2)
. . I BEN="" S BEN="??"
. . E S BEN=$P($G(^AUTTBEN(BEN,0)),U) I BEN="" S BEN="??"
. . N X S X=$P(^DD(9000001,1112,0),U,3)
. . N I,Y
. . F I=1:1:$L(X,";") S Y=$P(X,";",I) I ELG=$P(Y,":") S ELG=$P(Y,":",2)
. . I ELG="" S ELG="??"
. . S NAME=BEN_","_ELG
E S (NAME,P1112)="??"
S X=$G(^TMP("ABSPOS34",$J,NAME))
I X="" S $P(X,U,2)=NAME
S $P(X,U)=$P(X,U)+1
S ^TMP("ABSPOS34",$J,NAME)=X
Q
ABSPOS34 ; IHS/FCS/DRS - survey elig. status ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 QUIT
MAIN ;EP - option: ABSP BEN/ELIG SURVEY
+1 WRITE !!,"Survey BENEFICIARY/ELIGIBILITY status from recent prescriptions",!
+2 ;S X1=DT,X2=-60 D C^%DTC ; X = result
NEW X1,X2,X,%H
+3 ; 1 year ago
SET X=DT-10000
+4 NEW START,END
+5 SET START=$$DATE^ABSPOSU1("Start date: ",X,1,2970000,4000000,"E",300)
+6 IF 'START
QUIT
SET END=DT
+7 NEW POP
DO ^%ZIS
IF $GET(POP)
QUIT
+8 USE $PRINCIPAL
WRITE !,"...thinking...",!
+9 DO MAIN1(START)
+10 DO ^%ZISC
+11 QUIT
HEADING ;
+1 WRITE @IOF
+2 WRITE "Survey of Beneficiary/Eligibility Status (","ABSPOS34",")",?60,RPTDATE,!
+3 WRITE "For "
NEW Y
SET Y=START
XECUTE ^DD("DD")
WRITE Y
+4 IF START'=END
SET Y=END
XECUTE ^DD("DD")
WRITE "-",Y,!
+5 WRITE ?3,"Count",?10,"Status",!
+6 QUIT
MAIN1(START) ; START = fileman date.time to start search
+1 ; Build ^TMP("ABSPOS34",$J,ien)=count^name
+2 ; ^TMP("ABSPOS34",$J,"B",count)=INSIEN
+3 NEW RPTDATE
SET RPTDATE=$$NOWEXT^ABSPOSU1
+4 DO SURVEY(START)
+5 IF '$DATA(^TMP("ABSPOS34",$JOB))
WRITE !,"No prescriptions found?!",!
QUIT
+6 USE IO
DO HEADING
+7 NEW COUNT,INS,NUMBERS,X
+8 SET COUNT=""
FOR
SET COUNT=$ORDER(^TMP("ABSPOS34",$JOB,"B",COUNT),-1)
IF 'COUNT
QUIT
Begin DoDot:1
+9 SET INS=0
FOR
SET INS=$ORDER(^TMP("ABSPOS34",$JOB,"B",COUNT,INS))
IF INS=""
QUIT
Begin DoDot:2
+10 SET X=^TMP("ABSPOS34",$JOB,INS)
+11 WRITE $JUSTIFY(COUNT,7),?10,$EXTRACT($PIECE(X,U,2),1,40)
+12 IF $PIECE(X,U,3)]""
WRITE ?51,$PIECE(X,U,3)
+13 WRITE !
+14 IF $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$TEXT(+0))
SET INS=99999999
SET COUNT=1
End DoDot:2
End DoDot:1
+15 DO ENDRPT^ABSPOSU5()
+16 QUIT
SURVEY(START) ; START = fileman date.time
+1 NEW RXI,RXR,DOC,TIME
SET TIME=START
KILL ^TMP("ABSPOS34",$JOB)
+2 FOR
Begin DoDot:1
+3 SET RXI=""
FOR
SET RXI=$ORDER(^PSRX("AL",TIME,RXI))
IF 'RXI
QUIT
Begin DoDot:2
+4 SET RXR=""
FOR
SET RXR=$ORDER(^PSRX("AL",TIME,RXI,RXR))
IF RXR=""
QUIT
Begin DoDot:3
+5 DO SURVEY1
End DoDot:3
End DoDot:2
End DoDot:1
SET TIME=$ORDER(^PSRX("AL",TIME))
IF 'TIME
QUIT
+6 ; Now index it by count
+7 SET DOC=""
+8 FOR
SET DOC=$ORDER(^TMP("ABSPOS34",$JOB,DOC))
IF DOC=""
QUIT
IF "B"'[DOC
Begin DoDot:1
+9 NEW X
SET X=^TMP("ABSPOS34",$JOB,DOC)
NEW COUNT
SET COUNT=$PIECE(X,U)
+10 SET ^TMP("ABSPOS34",$JOB,"B",COUNT,DOC)=""
End DoDot:1
+11 QUIT
SURVEY1 ; given RXI, RXR
+1 NEW NAME,P1112,PAT
+2 SET PAT=$PIECE($GET(^PSRX(RXI,0)),U,2)
+3 IF PAT
Begin DoDot:1
+4 SET P1112=$PIECE($GET(^AUPNPAT(PAT,11)),U,11,12)
+5 IF P1112?."^"
SET (NAME,P1112)="???"
+6 IF '$TEST
Begin DoDot:2
+7 NEW BEN,ELG
SET BEN=$PIECE(P1112,U)
SET ELG=$PIECE(P1112,U,2)
+8 IF BEN=""
SET BEN="??"
+9 IF '$TEST
SET BEN=$PIECE($GET(^AUTTBEN(BEN,0)),U)
IF BEN=""
SET BEN="??"
+10 NEW X
SET X=$PIECE(^DD(9000001,1112,0),U,3)
+11 NEW I,Y
+12 FOR I=1:1:$LENGTH(X,";")
SET Y=$PIECE(X,";",I)
IF ELG=$PIECE(Y,":")
SET ELG=$PIECE(Y,":",2)
+13 IF ELG=""
SET ELG="??"
+14 SET NAME=BEN_","_ELG
End DoDot:2
End DoDot:1
+15 IF '$TEST
SET (NAME,P1112)="??"
+16 SET X=$GET(^TMP("ABSPOS34",$JOB,NAME))
+17 IF X=""
SET $PIECE(X,U,2)=NAME
+18 SET $PIECE(X,U)=$PIECE(X,U)+1
+19 SET ^TMP("ABSPOS34",$JOB,NAME)=X
+20 QUIT
