- 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
