- 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
