Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOS32

ABSPOS32.m

Go to the documentation of this file. 
  1. ABSPOS32 ; IHS/FCS/DRS - survey insurances ; 
  1.  ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
  1.  Q
  1. MAIN ;EP - option ABSP INSURER SURVEY
  1.  W !!,"Survey insurances from recent prescriptions to see which",!
  1.  W "additional formats we might like to have.",!
  1.  ; default to starting 60 days ago
  1.  N X1,X2,X,%H S X1=DT,X2=-60 D C^%DTC ; X = result
  1.  N START,END
  1.  S START=$$DATE^ABSPOSU1("Start date: ",X,1,2970000,4000000,"E",300)
  1.  Q:'START  S END=DT
  1.  N POP D ^%ZIS Q:$G(POP)
  1.  U $P W !,"...thinking...",!
  1.  I START D MAIN1(START)
  1.  D ^%ZISC
  1.  Q
  1. HEADING ;
  1.  W @IOF
  1.  W "Survey of Insurers (","ABSPOS32",")   ",$$NOWEXT^ABSPOSU1,!
  1.  W "For " N Y S Y=START X ^DD("DD") W Y
  1.  I START'=END S Y=END X ^DD("DD") W "-",Y,!
  1.  W ?3,"Count",?10,"Name",?50,"Now sending format",!
  1.  Q
  1. MAIN1(START)       ; START = fileman date.time to start search
  1.  ; Build ^TMP("ABSPOS32",$J,INSIEN)=count
  1.  ;       ^TMP("ABSPOS32",$J,"B",count)=INSIEN
  1.  DO SURVEY(START)
  1.  I '$D(^TMP("ABSPOS32",$J)) W !,"No prescriptions found?!",! Q
  1.  U IO D HEADING
  1.  N COUNT,INS,NUMBERS,X
  1.  S COUNT="" F  S COUNT=$O(^TMP("ABSPOS32",$J,"B",COUNT),-1) Q:'COUNT  D
  1.  . S INS=0 F  S INS=$O(^TMP("ABSPOS32",$J,"B",COUNT,INS)) Q:'INS  D
  1.  . . S X=^TMP("ABSPOS32",$J,INS)
  1.  . . W $J(COUNT,7),?10,$E($P(X,U,2)_"(`"_INS_")",1,40)
  1.  . . I $P(X,U,3)]"" W ?51,$P(X,U,3)
  1.  . . W !
  1.  . . I $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$T(+0)) S INS=999999999,COUNT=1
  1.  D ENDRPT^ABSPOSU5()
  1.  Q
  1. SURVEY(START)      ; START = fileman date.time
  1.  N RXI,RXR,DOC,TIME S TIME=START K ^TMP("ABSPOS32",$J)
  1.  F  D  S TIME=$O(^PSRX("AL",TIME)) Q:'TIME
  1.  . S RXI="" F  S RXI=$O(^PSRX("AL",TIME,RXI)) Q:'RXI  D
  1.  . . S RXR="" F  S RXR=$O(^PSRX("AL",TIME,RXI,RXR)) Q:RXR=""  D
  1.  . . . D SURVEY1
  1.  ; Now index it by count
  1.  S DOC=""
  1.  F  S DOC=$O(^TMP("ABSPOS32",$J,DOC)) Q:"B"[DOC  D
  1.  . N X S X=^TMP("ABSPOS32",$J,DOC) N COUNT S COUNT=$P(X,U)
  1.  . S ^TMP("ABSPOS32",$J,"B",COUNT,DOC)=""
  1.  Q
  1. SURVEY1 ; given RXI, RXR
  1.  N ABSBRXI,ABSBRXR,ABSBVMED,ABSBVISI,ABSBPATI
  1.  S ABSBRXI=RXI,ABSBRXR=RXR
  1.  I ABSBRXR S ABSBVMED=$P($G(^PSRX(ABSBRXI,1,ABSBRXR,999999911)),U)
  1.  E  S ABSBVMED=$P($G(^PSRX(ABSBRXI,999999911)),U)
  1.  I 'ABSBVMED D:0  Q
  1.  . W "No PCC link for ",ABSBRXI,",",ABSBRXR,! Q
  1.  I '$D(^AUPNVMED(ABSBVMED,0)) D:0  Q
  1.  . W "PCC link but '$D() on ABSBVMED=" W ABSBVMED W ! Q
  1.  S ABSBVISI=$P(^AUPNVMED(ABSBVMED,0),U,3)
  1.  S ABSBPATI=$P(^PSRX(ABSBRXI,0),U,2)
  1.  N ARRAY D INSURER^ABSPOS25(.ARRAY)
  1.  N INS S INS=+$G(ARRAY(1))
  1.  N X S X=$G(^TMP("ABSPOS32",$J,INS))
  1.  I X="" D
  1.  . I INS D
  1.  . . S X=$P($G(^AUTNINS(INS,0)),U)
  1.  . . I X="" S X="(Missing AUTNINS("_INS_")??"
  1.  . E  S X="(No insurance)"
  1.  . S X=U_X
  1.  . N FMT S FMT=$P($G(^ABSPEI(INS,100)),U)
  1.  . I FMT D
  1.  . . N FMTNAME S FMTNAME=$P($G(^ABSPF(9002313.92,FMT,0)),U)
  1.  . . I FMTNAME="" S FMTNAME="(?format `"_FMT_")"
  1.  . . S $P(X,U,3)=FMTNAME
  1.  S $P(X,U)=$P(X,U)+1
  1.  S ^TMP("ABSPOS32",$J,INS)=X
  1.  Q