ABSPOS33 ; IHS/FCS/DRS - survey divisions ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
Q
MAIN ;EP - option ABSP DIVISIONS SURVEY
W !!,"Survey DIVISION 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
D ^%ZIS Q:$G(POP)
U $P W !,"...thinking...",!
I START D MAIN1(START)
D ^%ZISC
Q
HEADING ;
W @IOF
W "Survey of Divisions (","ABSPOS33",") ",?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,"Name",!
Q
MAIN1(START) ; START = fileman date.time to start search
; Build ^TMP("ABSPOS33",$J,ien)=count^name
; ^TMP("ABSPOS33",$J,"B",count)=INSIEN
N RPTDATE S RPTDATE=$$NOWEXT^ABSPOSU1
DO SURVEY(START)
I '$D(^TMP("ABSPOS33",$J)) W !,"No prescriptions found?!",! Q
U IO D HEADING
N COUNT,INS,NUMBERS,X
S COUNT="" F S COUNT=$O(^TMP("ABSPOS33",$J,"B",COUNT),-1) Q:'COUNT D
. S INS=0 F S INS=$O(^TMP("ABSPOS33",$J,"B",COUNT,INS)) Q:'INS D
. . S X=^TMP("ABSPOS33",$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^ABSPOSU8()
Q
SURVEY(START) ; START = fileman date.time
N RXI,RXR,DOC,TIME S TIME=START K ^TMP("ABSPOS33",$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("ABSPOS33",$J,DOC)) Q:"B"[DOC D
. N X S X=^TMP("ABSPOS33",$J,DOC) N COUNT S COUNT=$P(X,U)
. S ^TMP("ABSPOS33",$J,"B",COUNT,DOC)=""
Q
SURVEY1 ; given RXI, RXR
N DIV,NAME
I RXR S DIV=$P($G(^PSRX(RXI,1,RXR,0)),U,9)
E S DIV=$P($G(^PSRX(RXI,2)),U,9)
I DIV="" S (DIV,NAME)="null?" ; *1.26*3*
E D
. S NAME=$P($G(^PS(59,DIV,0)),U)
. I NAME="" S NAME="`"_DIV_"?"
N X S X=$G(^TMP("ABSPOS33",$J,DIV))
I X="" S $P(X,U,2)=NAME
S $P(X,U)=$P(X,U)+1
S ^TMP("ABSPOS33",$J,DIV)=X
Q
ABSPOS33 ; IHS/FCS/DRS - survey divisions ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 QUIT
MAIN ;EP - option ABSP DIVISIONS SURVEY
+1 WRITE !!,"Survey DIVISION 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 DO ^%ZIS
IF $GET(POP)
QUIT
+8 USE $PRINCIPAL
WRITE !,"...thinking...",!
+9 IF START
DO MAIN1(START)
+10 DO ^%ZISC
+11 QUIT
HEADING ;
+1 WRITE @IOF
+2 WRITE "Survey of Divisions (","ABSPOS33",") ",?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,"Name",!
+6 QUIT
MAIN1(START) ; START = fileman date.time to start search
+1 ; Build ^TMP("ABSPOS33",$J,ien)=count^name
+2 ; ^TMP("ABSPOS33",$J,"B",count)=INSIEN
+3 NEW RPTDATE
SET RPTDATE=$$NOWEXT^ABSPOSU1
+4 DO SURVEY(START)
+5 IF '$DATA(^TMP("ABSPOS33",$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("ABSPOS33",$JOB,"B",COUNT),-1)
IF 'COUNT
QUIT
Begin DoDot:1
+9 SET INS=0
FOR
SET INS=$ORDER(^TMP("ABSPOS33",$JOB,"B",COUNT,INS))
IF 'INS
QUIT
Begin DoDot:2
+10 SET X=^TMP("ABSPOS33",$JOB,INS)
+11 WRITE $JUSTIFY(COUNT,7),?10,$EXTRACT($PIECE(X,U,2)_"(`"_INS_")",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=999999999
SET COUNT=1
End DoDot:2
End DoDot:1
+15 DO ENDRPT^ABSPOSU8()
+16 QUIT
SURVEY(START) ; START = fileman date.time
+1 NEW RXI,RXR,DOC,TIME
SET TIME=START
KILL ^TMP("ABSPOS33",$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("ABSPOS33",$JOB,DOC))
IF "B"[DOC
QUIT
Begin DoDot:1
+9 NEW X
SET X=^TMP("ABSPOS33",$JOB,DOC)
NEW COUNT
SET COUNT=$PIECE(X,U)
+10 SET ^TMP("ABSPOS33",$JOB,"B",COUNT,DOC)=""
End DoDot:1
+11 QUIT
SURVEY1 ; given RXI, RXR
+1 NEW DIV,NAME
+2 IF RXR
SET DIV=$PIECE($GET(^PSRX(RXI,1,RXR,0)),U,9)
+3 IF '$TEST
SET DIV=$PIECE($GET(^PSRX(RXI,2)),U,9)
+4 ; *1.26*3*
IF DIV=""
SET (DIV,NAME)="null?"
+5 IF '$TEST
Begin DoDot:1
+6 SET NAME=$PIECE($GET(^PS(59,DIV,0)),U)
+7 IF NAME=""
SET NAME="`"_DIV_"?"
End DoDot:1
+8 NEW X
SET X=$GET(^TMP("ABSPOS33",$JOB,DIV))
+9 IF X=""
SET $PIECE(X,U,2)=NAME
+10 SET $PIECE(X,U)=$PIECE(X,U)+1
+11 SET ^TMP("ABSPOS33",$JOB,DIV)=X
+12 QUIT
