ABSPOS32 ; IHS/FCS/DRS - survey insurances ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
Q
MAIN ;EP - option ABSP INSURER SURVEY
W !!,"Survey insurances from recent prescriptions to see which",!
W "additional formats we might like to have.",!
; default to starting 60 days ago
N X1,X2,X,%H S X1=DT,X2=-60 D C^%DTC ; X = result
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...",!
I START D MAIN1(START)
D ^%ZISC
Q
HEADING ;
W @IOF
W "Survey of Insurers (","ABSPOS32",") ",$$NOWEXT^ABSPOSU1,!
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,"Name",?50,"Now sending format",!
Q
MAIN1(START) ; START = fileman date.time to start search
; Build ^TMP("ABSPOS32",$J,INSIEN)=count
; ^TMP("ABSPOS32",$J,"B",count)=INSIEN
DO SURVEY(START)
I '$D(^TMP("ABSPOS32",$J)) W !,"No prescriptions found?!",! Q
U IO D HEADING
N COUNT,INS,NUMBERS,X
S COUNT="" F S COUNT=$O(^TMP("ABSPOS32",$J,"B",COUNT),-1) Q:'COUNT D
. S INS=0 F S INS=$O(^TMP("ABSPOS32",$J,"B",COUNT,INS)) Q:'INS D
. . S X=^TMP("ABSPOS32",$J,INS)
. . W $J(COUNT,7),?10,$E($P(X,U,2)_"(`"_INS_")",1,40)
. . I $P(X,U,3)]"" W ?51,$P(X,U,3)
. . W !
. . I $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$T(+0)) S INS=999999999,COUNT=1
D ENDRPT^ABSPOSU5()
Q
SURVEY(START) ; START = fileman date.time
N RXI,RXR,DOC,TIME S TIME=START K ^TMP("ABSPOS32",$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("ABSPOS32",$J,DOC)) Q:"B"[DOC D
. N X S X=^TMP("ABSPOS32",$J,DOC) N COUNT S COUNT=$P(X,U)
. S ^TMP("ABSPOS32",$J,"B",COUNT,DOC)=""
Q
SURVEY1 ; given RXI, RXR
N ABSBRXI,ABSBRXR,ABSBVMED,ABSBVISI,ABSBPATI
S ABSBRXI=RXI,ABSBRXR=RXR
I ABSBRXR S ABSBVMED=$P($G(^PSRX(ABSBRXI,1,ABSBRXR,999999911)),U)
E S ABSBVMED=$P($G(^PSRX(ABSBRXI,999999911)),U)
I 'ABSBVMED D:0 Q
. W "No PCC link for ",ABSBRXI,",",ABSBRXR,! Q
I '$D(^AUPNVMED(ABSBVMED,0)) D:0 Q
. W "PCC link but '$D() on ABSBVMED=" W ABSBVMED W ! Q
S ABSBVISI=$P(^AUPNVMED(ABSBVMED,0),U,3)
S ABSBPATI=$P(^PSRX(ABSBRXI,0),U,2)
N ARRAY D INSURER^ABSPOS25(.ARRAY)
N INS S INS=+$G(ARRAY(1))
N X S X=$G(^TMP("ABSPOS32",$J,INS))
I X="" D
. I INS D
. . S X=$P($G(^AUTNINS(INS,0)),U)
. . I X="" S X="(Missing AUTNINS("_INS_")??"
. E S X="(No insurance)"
. S X=U_X
. N FMT S FMT=$P($G(^ABSPEI(INS,100)),U)
. I FMT D
. . N FMTNAME S FMTNAME=$P($G(^ABSPF(9002313.92,FMT,0)),U)
. . I FMTNAME="" S FMTNAME="(?format `"_FMT_")"
. . S $P(X,U,3)=FMTNAME
S $P(X,U)=$P(X,U)+1
S ^TMP("ABSPOS32",$J,INS)=X
Q
ABSPOS32 ; IHS/FCS/DRS - survey insurances ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 QUIT
MAIN ;EP - option ABSP INSURER SURVEY
+1 WRITE !!,"Survey insurances from recent prescriptions to see which",!
+2 WRITE "additional formats we might like to have.",!
+3 ; default to starting 60 days ago
+4 ; X = result
NEW X1,X2,X,%H
SET X1=DT
SET X2=-60
DO C^%DTC
+5 NEW START,END
+6 SET START=$$DATE^ABSPOSU1("Start date: ",X,1,2970000,4000000,"E",300)
+7 IF 'START
QUIT
SET END=DT
+8 NEW POP
DO ^%ZIS
IF $GET(POP)
QUIT
+9 USE $PRINCIPAL
WRITE !,"...thinking...",!
+10 IF START
DO MAIN1(START)
+11 DO ^%ZISC
+12 QUIT
HEADING ;
+1 WRITE @IOF
+2 WRITE "Survey of Insurers (","ABSPOS32",") ",$$NOWEXT^ABSPOSU1,!
+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,"Name",?50,"Now sending format",!
+6 QUIT
MAIN1(START) ; START = fileman date.time to start search
+1 ; Build ^TMP("ABSPOS32",$J,INSIEN)=count
+2 ; ^TMP("ABSPOS32",$J,"B",count)=INSIEN
+3 DO SURVEY(START)
+4 IF '$DATA(^TMP("ABSPOS32",$JOB))
WRITE !,"No prescriptions found?!",!
QUIT
+5 USE IO
DO HEADING
+6 NEW COUNT,INS,NUMBERS,X
+7 SET COUNT=""
FOR
SET COUNT=$ORDER(^TMP("ABSPOS32",$JOB,"B",COUNT),-1)
IF 'COUNT
QUIT
Begin DoDot:1
+8 SET INS=0
FOR
SET INS=$ORDER(^TMP("ABSPOS32",$JOB,"B",COUNT,INS))
IF 'INS
QUIT
Begin DoDot:2
+9 SET X=^TMP("ABSPOS32",$JOB,INS)
+10 WRITE $JUSTIFY(COUNT,7),?10,$EXTRACT($PIECE(X,U,2)_"(`"_INS_")",1,40)
+11 IF $PIECE(X,U,3)]""
WRITE ?51,$PIECE(X,U,3)
+12 WRITE !
+13 IF $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$TEXT(+0))
SET INS=999999999
SET COUNT=1
End DoDot:2
End DoDot:1
+14 DO ENDRPT^ABSPOSU5()
+15 QUIT
SURVEY(START) ; START = fileman date.time
+1 NEW RXI,RXR,DOC,TIME
SET TIME=START
KILL ^TMP("ABSPOS32",$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("ABSPOS32",$JOB,DOC))
IF "B"[DOC
QUIT
Begin DoDot:1
+9 NEW X
SET X=^TMP("ABSPOS32",$JOB,DOC)
NEW COUNT
SET COUNT=$PIECE(X,U)
+10 SET ^TMP("ABSPOS32",$JOB,"B",COUNT,DOC)=""
End DoDot:1
+11 QUIT
SURVEY1 ; given RXI, RXR
+1 NEW ABSBRXI,ABSBRXR,ABSBVMED,ABSBVISI,ABSBPATI
+2 SET ABSBRXI=RXI
SET ABSBRXR=RXR
+3 IF ABSBRXR
SET ABSBVMED=$PIECE($GET(^PSRX(ABSBRXI,1,ABSBRXR,999999911)),U)
+4 IF '$TEST
SET ABSBVMED=$PIECE($GET(^PSRX(ABSBRXI,999999911)),U)
+5 IF 'ABSBVMED
IF 0
Begin DoDot:1
+6 WRITE "No PCC link for ",ABSBRXI,",",ABSBRXR,!
QUIT
End DoDot:1
QUIT
+7 IF '$DATA(^AUPNVMED(ABSBVMED,0))
IF 0
Begin DoDot:1
+8 WRITE "PCC link but '$D() on ABSBVMED="
WRITE ABSBVMED
WRITE !
QUIT
End DoDot:1
QUIT
+9 SET ABSBVISI=$PIECE(^AUPNVMED(ABSBVMED,0),U,3)
+10 SET ABSBPATI=$PIECE(^PSRX(ABSBRXI,0),U,2)
+11 NEW ARRAY
DO INSURER^ABSPOS25(.ARRAY)
+12 NEW INS
SET INS=+$GET(ARRAY(1))
+13 NEW X
SET X=$GET(^TMP("ABSPOS32",$JOB,INS))
+14 IF X=""
Begin DoDot:1
+15 IF INS
Begin DoDot:2
+16 SET X=$PIECE($GET(^AUTNINS(INS,0)),U)
+17 IF X=""
SET X="(Missing AUTNINS("_INS_")??"
End DoDot:2
+18 IF '$TEST
SET X="(No insurance)"
+19 SET X=U_X
+20 NEW FMT
SET FMT=$PIECE($GET(^ABSPEI(INS,100)),U)
+21 IF FMT
Begin DoDot:2
+22 NEW FMTNAME
SET FMTNAME=$PIECE($GET(^ABSPF(9002313.92,FMT,0)),U)
+23 IF FMTNAME=""
SET FMTNAME="(?format `"_FMT_")"
+24 SET $PIECE(X,U,3)=FMTNAME
End DoDot:2
End DoDot:1
+25 SET $PIECE(X,U)=$PIECE(X,U)+1
+26 SET ^TMP("ABSPOS32",$JOB,INS)=X
+27 QUIT
