ABSPOSRU ;IHS/OIT/SCR - Utilities for POS Insurance Report ;
;;1.0;PHARMACY POINT OF SALE;**38,46,50**;JUN 01, 2001 ;Build 38
;;BASED ON FILE ABMRMCRD - 2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
Q
MEDICARE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPPHRM) ; EP From ABSPOSR7
N ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPPIEN,ABSPHRNN,ABSPOUT
N ABSPPN,ABSPDPT,ABSPHRL,ABSPPAT
S ABSPEN=0,ABSPQUIT=0
F S ABSPEN=$O(^AUPNMCR(ABSPEN)) Q:+ABSPEN=0 D
.S ABSPDPT=$P(^AUPNMCR(ABSPEN,0),U,1)
.Q:$G(^DPT(ABSPDPT,0))="" ;Still have to look out for that...
.I $D(^DPT(ABSPDPT,.35)),$P(^(.35),U,1)]"",$P(^(.35),U,1)<ABSPELDT Q
.S ABSPEIEN=0
.F S ABSPEIEN=$O(^AUPNMCR(ABSPEN,11,ABSPEIEN)) Q:+ABSPEIEN=0 D
..S ABSPCOV=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,3) ;coverage type
..Q:ABSPCOV'="D"
..S ABSPPIEN=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,4) ; plan name (pointer to ins file)
..I ($G(ABSPPIEN)="") S ABSPQUIT=1 Q
..I ($G(ABSPLIST(ABSPPIEN))="") S ABSPQUIT=1 Q ;no entry for insurer on requested list
..I ABSPDEAD=0,($P($G(^DPT(ABSPEN,.35)),U)'="") S ABSPQUIT=1 Q ;check exclude flag and DOD
..S ABSPSDT=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U) ;ELIG START DATE
..S ABSPEDT=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,2) ;ELIG END DATE
..I (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT="")) D
...S ABSPHRN=0
...F S ABSPHRN=$O(^AUPNPAT(ABSPEN,41,ABSPHRN)) Q:+ABSPHRN=0 D
....S ABSPHRL=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,1) ;location?
....Q:ABSPHRL=""
....;now look in ABSPPHRM array to see if this location is one that we are interested in...
....S ABSPPHRM=""
....F S ABSPPHRM=$O(ABSPPHRM(ABSPPHRM)) Q:ABSPPHRM="" D
.....S ABSPOUT=""
.....F S ABSPOUT=$O(ABSPPHRM(ABSPPHRM,ABSPOUT)) Q:ABSPOUT="" D
......;Q:$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,2)'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
......Q:ABSPOUT'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
......S ABSPHRNS=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5) ;inactive?
......I (ABSPDEAD=0&ABSPHRN)="I" S ABSPQUIT=1 Q ;check exclude inactive flag and status
......S ABSPPNAM=$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,1)
......Q:ABSPPNAM=""
......;S ABSPPHRM(ABSPPHRM,ABSPHRL)=ABSPPNAM
......S ABSPNAM=$P($G(^AUTNINS(ABSPPIEN,0)),U) ;insurer name
......; S ABSPPN=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,6) ;ID
......S ABSPPN=$$GETMCR^AGUTL(ABSPEN,ABSPELDT) ;ID ; /IHS/OIT/RAM ; 18 DEC 17 ; new method of retrieving MCRE number / MBI.
......S ABSPHRNN=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2) ;HRN
......S ABSPPAT(ABSPHRNN)=$G(ABSPPAT(ABSPHRNN))+1 ;count the number of times we use this patient hrn
......S ABSPDPT(ABSPDPT)=$G(ABSPDPT(ABSPDPT))+1 ;count the number of times we use this patient DPT
......S ^TMP($J,"ABSPOSR7",ABSPPHRM,ABSPHRL,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
......S ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN)=$G(ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN))+1
......S ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL")=$G(ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL"))+1
......S:($G(ABSPPAT(ABSPHRNN))=1) ABSPTOT(ABSPPHRM,"TOTAL")=$G(ABSPTOT(ABSPPHRM,"TOTAL"))+1
......S:($G(ABSPDPT(ABSPDPT))=1) ABSPTOT("TOTAL")=$G(ABSPTOT("TOTAL"))+1
Q
;
PRIVATE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPPHRM) ; EP FROM ABSPOSR7
N ABSPTIEN,ABSPEN,ABSPNS,ABSPSDT,ABSPEDT,ABSPHRN,ABSPHRNS,ABSPNAM,ABSPHRNN,ABSPPN,ABSPHRL,ABSPOUT
S ABSPTIEN=0
F S ABSPTIEN=$O(^AUPNPRVT(ABSPTIEN)) Q:+ABSPTIEN=0 D
.S ABSPEN=0
.F S ABSPEN=$O(^AUPNPRVT(ABSPTIEN,11,ABSPEN)) Q:+ABSPEN=0 D
..S ABSPNS=$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U)
..Q:$G(ABSPLIST(ABSPNS))="" ;not on list
..S ABSPSDT=$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,6)
..S ABSPEDT=$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,7)
..I ((ABSPSDT=ABSPELDT)!(ABSPSDT<ABSPELDT)),((ABSPEDT>ABSPELDT)!(ABSPEDT="")) D ;inside date range
...S ABSPHRN=0
...F S ABSPHRN=$O(^AUPNPAT(ABSPTIEN,41,ABSPHRN)) Q:+ABSPHRN=0 D
....S ABSPHRL=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,1) ;location?
....Q:ABSPHRL=""
....S ABSPPHRM=""
....;now look in ABSPPHRM array to see if this location is one that we are interested in...
....F S ABSPPHRM=$O(ABSPPHRM(ABSPPHRM)) Q:ABSPPHRM="" D
.....S ABSPOUT=""
.....N ABSPPAT
.....F S ABSPOUT=$O(ABSPPHRM(ABSPPHRM,ABSPOUT)) Q:ABSPOUT="" D
......;Q:$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,2)'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
......Q:ABSPOUT'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
......S ABSPHRNS=$P($G(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,5) ;inactive?
......I ABSPDEAD=0,ABSPHRNS="I" Q ;check exclude inactive flag and status
......S ABSPPNAM=$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,1)
......Q:ABSPPNAM=""
......;S ABSPPHRM(ABSPPHRM,ABSPHRL)=ABSPPNAM
......S ABSPNAM=$P($G(^AUTNINS(ABSPNS,0)),U) ;insurer name
......S:$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8)'="" ABSPPN=$P($G(^AUPN3PPH($P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8),0)),U,4)
......S ABSPHRNN=$P($G(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,2) ;HRN
......S:ABSPHRNN="" ABSPHRNN="NONE"
......S ABSPPAT(ABSPHRNN)=$G(ABSPPAT(ABSPHRNN))+1 ;count the number of times we use this patient hrn
......S ABSPDPT(ABSPTIEN)=$G(ABSPDPT(ABSPTIEN))+1 ;count the number of times we use this patient IEN
......S ^TMP($J,"ABSPOSR7",ABSPPHRM,ABSPHRL,ABSPNS,ABSPTIEN)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
......S ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPNS)=+$G(ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPNS))+1
......S ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL")=$G(ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL"))+1
......S ABSPTOT(ABSPPHRM,"TOTAL")=$G(ABSPTOT(ABSPPHRM,"TOTAL"))+1
......S:($G(ABSPPAT(ABSPHRNN))=1) ABSPTOT(ABSPPHRM,"TOTAL")=$G(ABSPTOT(ABSPPHRM,"TOTAL"))+1
......S:($G(ABSPDPT(ABSPTIEN))=1) ABSPTOT("TOTAL")=$G(ABSPTOT("TOTAL"))+1
Q
;
MEDICAID(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPPHRM) ;EP FROM ABSPOSR7
N ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPINSN,ABSPHRNN,ABSPPN
N ABSPPIEN,ABSPPN,ABSPDPT,ABSPHRL,ABSPPAT,ABSPFND,ABSPINSP,ABSPMFI,ABSPSTP,ABSPOUT
S ABSPEN=0,ABSPQUIT=0
F S ABSPEN=$O(^AUPNMCD(ABSPEN)) Q:+ABSPEN=0 D
.S ABSPDPT=$P(^AUPNMCD(ABSPEN,0),U,1)
.Q:$G(^DPT(ABSPDPT,0))="" ;Still have to look out for that...
.I $D(^DPT(ABSPDPT,.35)),$P(^(.35),U,1)]"",$P(^(.35),U,1)<ABSPELDT Q
.Q:$G(^AUPNMCD(ABSPEN,0))="" ;Why would this happen?
.S ABSPINSP=$P(^AUPNMCD(ABSPEN,0),U,2) ;POINTER TO INSURER FILE
.I $P($G(^AUTNINS(ABSPINSP,0)),U,1)="MEDICAID" D
..S ABSPSTP=$P($G(^AUPNMCD(ABSPEN,0)),U,4) ;pointer to the state file
..S ABSPMFI=""
..S ABSPFND=0
..F S ABSPMFI=$O(^AUTNINS(ABSPINSP,13,ABSPMFI)) Q:(ABSPMFI="")!ABSPFND D
...I $P($G(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,1)=ABSPSTP D
....S ABSPPIEN=$P($G(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,2)
....S ABSPFND=1
.S ABSPEIEN=0
.F S ABSPEIEN=$O(^AUPNMCD(ABSPEN,11,ABSPEIEN)) Q:+ABSPEIEN=0 D
..I ($G(ABSPPIEN)="") S ABSPQUIT=1 Q
..I ($G(ABSPLIST(ABSPPIEN))="") S ABSPQUIT=1 Q ;no entry for insurer on requested list
..I ABSPDEAD=0,($P($G(^DPT(ABSPEN,.35)),U)'="") S ABSPQUIT=1 Q ;check exclude flag and DOD
..S ABSPSDT=$P($G(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U) ;ELIG START DATE
..S ABSPEDT=$P($G(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U,2) ;ELIG END DATE
..Q:ABSPSDT=""
..I (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT="")) D
...S ABSPHRN=0
...F S ABSPHRN=$O(^AUPNPAT(ABSPEN,41,ABSPHRN)) Q:+ABSPHRN=0 D
....S ABSPHRL=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,1) ;location?
....Q:ABSPHRL=""
....S ABSPPHRM=""
....;now look in ABSPPHRM array to see if this location is one that we are interested in...
....F S ABSPPHRM=$O(ABSPPHRM(ABSPPHRM)) Q:ABSPPHRM="" D
.....S ABSPOUT=""
.....F S ABSPOUT=$O(ABSPPHRM(ABSPPHRM,ABSPOUT)) Q:ABSPOUT="" D
......;Q:$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,2)'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
......Q:ABSPOUT'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
......S ABSPHRNS=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5) ;inactive?
......I (ABSPDEAD=0&ABSPHRN)="I" S ABSPQUIT=1 Q ;check exclude inactive flag and status
......S ABSPPNAM=$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,1)
......Q:ABSPPNAM=""
......S ABSPNAM=$P($G(^AUTNINS(ABSPPIEN,0)),U) ;insurer name
......S ABSPPN=$P($G(^AUPNMCD(ABSPEN,0)),U,3) ;ID
......S ABSPHRNN=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2) ;HRN
......S ABSPPAT(ABSPHRNN)=$G(ABSPPAT(ABSPHRNN))+1 ;count the number of times we use this patient hrn
......S ABSPDPT(ABSPDPT)=$G(ABSPDPT(ABSPDPT))+1 ;count the number of times we use this patient DPT
......S ^TMP($J,"ABSPOSR7",ABSPPHRM,ABSPHRL,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
......S ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN)=+$G(ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN))+1
......S ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL")=+$G(ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL"))+1
......S:($G(ABSPPAT(ABSPHRNN))=1) ABSPTOT(ABSPPHRM,"TOTAL")=$G(ABSPTOT(ABSPPHRM,"TOTAL"))+1
......S:($G(ABSPDPT(ABSPDPT))=1) ABSPTOT("TOTAL")=$G(ABSPTOT("TOTAL"))+1
Q
;
;OIT/CAS/RCS 091213 Patch 46 Move subroutines
BDT() ;ENTER BEGINING DATE
N ABSPBDT,DIR,X1,X
W !
K DIR
S DIR(0)="DEX"
S DIR("A")="Enter Beginning Prescription Release Date"
D ^DIR
I $D(DIRUT) Q -1
S ABSPBDT=+Y
S X1=ABSPBDT D C^%DTC
Q X
EDT() ;ENTER END DATE
N ABSPEDT,DIR,X1,X
W !
K DIR
S DIR(0)="DEX"
S DIR("A")="Enter Ending Prescription Release Date"
D ^DIR
I $D(DIRUT) Q -1
S ABSPEDT=+Y
S X1=ABSPEDT D C^%DTC
Q X
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
N DIC,X,Y
S DIC="^ABSP(9002313.56,"
S DIC(0)="AEMQVZ"
S DIC("A")="Please Select a Pharmacy or leave blank for ALL: "
D ^DIC K DIC
I X[U Q -1
I Y=-1 S ABSPPPHM="ALL"
I Y>-1 S ABSPPPHM=$P(Y,U,1),ABSPPHMN=$P(Y,U,2)
Q 1
DEVSEL ; SELECT DEVICE
N ABSPSTOP
S ABSPSTOP=0
D ^%ZIS
I POP D
.D ^%ZIS
.Q
I $D(DUOUT) D
.D ZEND^ABSPOSRZ
.S ABSPSTOP=1
.Q
Q:ABSPSTOP
I POP D
.W "DEVICE UNAVAILABLE" G DEVSEL
Q
ABSPOSRU ;IHS/OIT/SCR - Utilities for POS Insurance Report ;
+1 ;;1.0;PHARMACY POINT OF SALE;**38,46,50**;JUN 01, 2001 ;Build 38
+2 ;;BASED ON FILE ABMRMCRD - 2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+3 QUIT
MEDICARE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPPHRM) ; EP From ABSPOSR7
+1 NEW ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPPIEN,ABSPHRNN,ABSPOUT
+2 NEW ABSPPN,ABSPDPT,ABSPHRL,ABSPPAT
+3 SET ABSPEN=0
SET ABSPQUIT=0
+4 FOR
SET ABSPEN=$ORDER(^AUPNMCR(ABSPEN))
IF +ABSPEN=0
QUIT
Begin DoDot:1
+5 SET ABSPDPT=$PIECE(^AUPNMCR(ABSPEN,0),U,1)
+6 ;Still have to look out for that...
IF $GET(^DPT(ABSPDPT,0))=""
QUIT
+7 IF $DATA(^DPT(ABSPDPT,.35))
IF $PIECE(^(.35),U,1)]""
IF $PIECE(^(.35),U,1)<ABSPELDT
QUIT
+8 SET ABSPEIEN=0
+9 FOR
SET ABSPEIEN=$ORDER(^AUPNMCR(ABSPEN,11,ABSPEIEN))
IF +ABSPEIEN=0
QUIT
Begin DoDot:2
+10 ;coverage type
SET ABSPCOV=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,3)
+11 IF ABSPCOV'="D"
QUIT
+12 ; plan name (pointer to ins file)
SET ABSPPIEN=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,4)
+13 IF ($GET(ABSPPIEN)="")
SET ABSPQUIT=1
QUIT
+14 ;no entry for insurer on requested list
IF ($GET(ABSPLIST(ABSPPIEN))="")
SET ABSPQUIT=1
QUIT
+15 ;check exclude flag and DOD
IF ABSPDEAD=0
IF ($PIECE($GET(^DPT(ABSPEN,.35)),U)'="")
SET ABSPQUIT=1
QUIT
+16 ;ELIG START DATE
SET ABSPSDT=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U)
+17 ;ELIG END DATE
SET ABSPEDT=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,2)
+18 IF (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT=""))
Begin DoDot:3
+19 SET ABSPHRN=0
+20 FOR
SET ABSPHRN=$ORDER(^AUPNPAT(ABSPEN,41,ABSPHRN))
IF +ABSPHRN=0
QUIT
Begin DoDot:4
+21 ;location?
SET ABSPHRL=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,1)
+22 IF ABSPHRL=""
QUIT
+23 ;now look in ABSPPHRM array to see if this location is one that we are interested in...
+24 SET ABSPPHRM=""
+25 FOR
SET ABSPPHRM=$ORDER(ABSPPHRM(ABSPPHRM))
IF ABSPPHRM=""
QUIT
Begin DoDot:5
+26 SET ABSPOUT=""
+27 FOR
SET ABSPOUT=$ORDER(ABSPPHRM(ABSPPHRM,ABSPOUT))
IF ABSPOUT=""
QUIT
Begin DoDot:6
+28 ;Q:$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,2)'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
+29 ;add info about this patient when we find a pharmacy/outpatient match
IF ABSPOUT'=ABSPHRL
QUIT
+30 ;inactive?
SET ABSPHRNS=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5)
+31 ;check exclude inactive flag and status
IF (ABSPDEAD=0&ABSPHRN)="I"
SET ABSPQUIT=1
QUIT
+32 SET ABSPPNAM=$PIECE(ABSPPHRM(ABSPPHRM,ABSPOUT),U,1)
+33 IF ABSPPNAM=""
QUIT
+34 ;S ABSPPHRM(ABSPPHRM,ABSPHRL)=ABSPPNAM
+35 ;insurer name
SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPPIEN,0)),U)
+36 ; S ABSPPN=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,6) ;ID
+37 ;ID ; /IHS/OIT/RAM ; 18 DEC 17 ; new method of retrieving MCRE number / MBI.
SET ABSPPN=$$GETMCR^AGUTL(ABSPEN,ABSPELDT)
+38 ;HRN
SET ABSPHRNN=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2)
+39 ;count the number of times we use this patient hrn
SET ABSPPAT(ABSPHRNN)=$GET(ABSPPAT(ABSPHRNN))+1
+40 ;count the number of times we use this patient DPT
SET ABSPDPT(ABSPDPT)=$GET(ABSPDPT(ABSPDPT))+1
+41 SET ^TMP($JOB,"ABSPOSR7",ABSPPHRM,ABSPHRL,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
+42 SET ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN)=$GET(ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN))+1
+43 SET ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL")=$GET(ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL"))+1
+44 IF ($GET(ABSPPAT(ABSPHRNN))=1)
SET ABSPTOT(ABSPPHRM,"TOTAL")=$GET(ABSPTOT(ABSPPHRM,"TOTAL"))+1
+45 IF ($GET(ABSPDPT(ABSPDPT))=1)
SET ABSPTOT("TOTAL")=$GET(ABSPTOT("TOTAL"))+1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
+47 ;
PRIVATE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPPHRM) ; EP FROM ABSPOSR7
+1 NEW ABSPTIEN,ABSPEN,ABSPNS,ABSPSDT,ABSPEDT,ABSPHRN,ABSPHRNS,ABSPNAM,ABSPHRNN,ABSPPN,ABSPHRL,ABSPOUT
+2 SET ABSPTIEN=0
+3 FOR
SET ABSPTIEN=$ORDER(^AUPNPRVT(ABSPTIEN))
IF +ABSPTIEN=0
QUIT
Begin DoDot:1
+4 SET ABSPEN=0
+5 FOR
SET ABSPEN=$ORDER(^AUPNPRVT(ABSPTIEN,11,ABSPEN))
IF +ABSPEN=0
QUIT
Begin DoDot:2
+6 SET ABSPNS=$PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U)
+7 ;not on list
IF $GET(ABSPLIST(ABSPNS))=""
QUIT
+8 SET ABSPSDT=$PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,6)
+9 SET ABSPEDT=$PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,7)
+10 ;inside date range
IF ((ABSPSDT=ABSPELDT)!(ABSPSDT<ABSPELDT))
IF ((ABSPEDT>ABSPELDT)!(ABSPEDT=""))
Begin DoDot:3
+11 SET ABSPHRN=0
+12 FOR
SET ABSPHRN=$ORDER(^AUPNPAT(ABSPTIEN,41,ABSPHRN))
IF +ABSPHRN=0
QUIT
Begin DoDot:4
+13 ;location?
SET ABSPHRL=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,1)
+14 IF ABSPHRL=""
QUIT
+15 SET ABSPPHRM=""
+16 ;now look in ABSPPHRM array to see if this location is one that we are interested in...
+17 FOR
SET ABSPPHRM=$ORDER(ABSPPHRM(ABSPPHRM))
IF ABSPPHRM=""
QUIT
Begin DoDot:5
+18 SET ABSPOUT=""
+19 NEW ABSPPAT
+20 FOR
SET ABSPOUT=$ORDER(ABSPPHRM(ABSPPHRM,ABSPOUT))
IF ABSPOUT=""
QUIT
Begin DoDot:6
+21 ;Q:$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,2)'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
+22 ;add info about this patient when we find a pharmacy/outpatient match
IF ABSPOUT'=ABSPHRL
QUIT
+23 ;inactive?
SET ABSPHRNS=$PIECE($GET(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,5)
+24 ;check exclude inactive flag and status
IF ABSPDEAD=0
IF ABSPHRNS="I"
QUIT
+25 SET ABSPPNAM=$PIECE(ABSPPHRM(ABSPPHRM,ABSPOUT),U,1)
+26 IF ABSPPNAM=""
QUIT
+27 ;S ABSPPHRM(ABSPPHRM,ABSPHRL)=ABSPPNAM
+28 ;insurer name
SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPNS,0)),U)
+29 IF $PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8)'=""
SET ABSPPN=$PIECE($GET(^AUPN3PPH($PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8),0)),U,4)
+30 ;HRN
SET ABSPHRNN=$PIECE($GET(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,2)
+31 IF ABSPHRNN=""
SET ABSPHRNN="NONE"
+32 ;count the number of times we use this patient hrn
SET ABSPPAT(ABSPHRNN)=$GET(ABSPPAT(ABSPHRNN))+1
+33 ;count the number of times we use this patient IEN
SET ABSPDPT(ABSPTIEN)=$GET(ABSPDPT(ABSPTIEN))+1
+34 SET ^TMP($JOB,"ABSPOSR7",ABSPPHRM,ABSPHRL,ABSPNS,ABSPTIEN)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
+35 SET ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPNS)=+$GET(ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPNS))+1
+36 SET ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL")=$GET(ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL"))+1
+37 SET ABSPTOT(ABSPPHRM,"TOTAL")=$GET(ABSPTOT(ABSPPHRM,"TOTAL"))+1
+38 IF ($GET(ABSPPAT(ABSPHRNN))=1)
SET ABSPTOT(ABSPPHRM,"TOTAL")=$GET(ABSPTOT(ABSPPHRM,"TOTAL"))+1
+39 IF ($GET(ABSPDPT(ABSPTIEN))=1)
SET ABSPTOT("TOTAL")=$GET(ABSPTOT("TOTAL"))+1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
MEDICAID(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPPHRM) ;EP FROM ABSPOSR7
+1 NEW ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPINSN,ABSPHRNN,ABSPPN
+2 NEW ABSPPIEN,ABSPPN,ABSPDPT,ABSPHRL,ABSPPAT,ABSPFND,ABSPINSP,ABSPMFI,ABSPSTP,ABSPOUT
+3 SET ABSPEN=0
SET ABSPQUIT=0
+4 FOR
SET ABSPEN=$ORDER(^AUPNMCD(ABSPEN))
IF +ABSPEN=0
QUIT
Begin DoDot:1
+5 SET ABSPDPT=$PIECE(^AUPNMCD(ABSPEN,0),U,1)
+6 ;Still have to look out for that...
IF $GET(^DPT(ABSPDPT,0))=""
QUIT
+7 IF $DATA(^DPT(ABSPDPT,.35))
IF $PIECE(^(.35),U,1)]""
IF $PIECE(^(.35),U,1)<ABSPELDT
QUIT
+8 ;Why would this happen?
IF $GET(^AUPNMCD(ABSPEN,0))=""
QUIT
+9 ;POINTER TO INSURER FILE
SET ABSPINSP=$PIECE(^AUPNMCD(ABSPEN,0),U,2)
+10 IF $PIECE($GET(^AUTNINS(ABSPINSP,0)),U,1)="MEDICAID"
Begin DoDot:2
+11 ;pointer to the state file
SET ABSPSTP=$PIECE($GET(^AUPNMCD(ABSPEN,0)),U,4)
+12 SET ABSPMFI=""
+13 SET ABSPFND=0
+14 FOR
SET ABSPMFI=$ORDER(^AUTNINS(ABSPINSP,13,ABSPMFI))
IF (ABSPMFI="")!ABSPFND
QUIT
Begin DoDot:3
+15 IF $PIECE($GET(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,1)=ABSPSTP
Begin DoDot:4
+16 SET ABSPPIEN=$PIECE($GET(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,2)
+17 SET ABSPFND=1
End DoDot:4
End DoDot:3
End DoDot:2
+18 SET ABSPEIEN=0
+19 FOR
SET ABSPEIEN=$ORDER(^AUPNMCD(ABSPEN,11,ABSPEIEN))
IF +ABSPEIEN=0
QUIT
Begin DoDot:2
+20 IF ($GET(ABSPPIEN)="")
SET ABSPQUIT=1
QUIT
+21 ;no entry for insurer on requested list
IF ($GET(ABSPLIST(ABSPPIEN))="")
SET ABSPQUIT=1
QUIT
+22 ;check exclude flag and DOD
IF ABSPDEAD=0
IF ($PIECE($GET(^DPT(ABSPEN,.35)),U)'="")
SET ABSPQUIT=1
QUIT
+23 ;ELIG START DATE
SET ABSPSDT=$PIECE($GET(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U)
+24 ;ELIG END DATE
SET ABSPEDT=$PIECE($GET(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U,2)
+25 IF ABSPSDT=""
QUIT
+26 IF (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT=""))
Begin DoDot:3
+27 SET ABSPHRN=0
+28 FOR
SET ABSPHRN=$ORDER(^AUPNPAT(ABSPEN,41,ABSPHRN))
IF +ABSPHRN=0
QUIT
Begin DoDot:4
+29 ;location?
SET ABSPHRL=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,1)
+30 IF ABSPHRL=""
QUIT
+31 SET ABSPPHRM=""
+32 ;now look in ABSPPHRM array to see if this location is one that we are interested in...
+33 FOR
SET ABSPPHRM=$ORDER(ABSPPHRM(ABSPPHRM))
IF ABSPPHRM=""
QUIT
Begin DoDot:5
+34 SET ABSPOUT=""
+35 FOR
SET ABSPOUT=$ORDER(ABSPPHRM(ABSPPHRM,ABSPOUT))
IF ABSPOUT=""
QUIT
Begin DoDot:6
+36 ;Q:$P(ABSPPHRM(ABSPPHRM,ABSPOUT),U,2)'=ABSPHRL ;add info about this patient when we find a pharmacy/outpatient match
+37 ;add info about this patient when we find a pharmacy/outpatient match
IF ABSPOUT'=ABSPHRL
QUIT
+38 ;inactive?
SET ABSPHRNS=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5)
+39 ;check exclude inactive flag and status
IF (ABSPDEAD=0&ABSPHRN)="I"
SET ABSPQUIT=1
QUIT
+40 SET ABSPPNAM=$PIECE(ABSPPHRM(ABSPPHRM,ABSPOUT),U,1)
+41 IF ABSPPNAM=""
QUIT
+42 ;insurer name
SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPPIEN,0)),U)
+43 ;ID
SET ABSPPN=$PIECE($GET(^AUPNMCD(ABSPEN,0)),U,3)
+44 ;HRN
SET ABSPHRNN=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2)
+45 ;count the number of times we use this patient hrn
SET ABSPPAT(ABSPHRNN)=$GET(ABSPPAT(ABSPHRNN))+1
+46 ;count the number of times we use this patient DPT
SET ABSPDPT(ABSPDPT)=$GET(ABSPDPT(ABSPDPT))+1
+47 SET ^TMP($JOB,"ABSPOSR7",ABSPPHRM,ABSPHRL,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
+48 SET ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN)=+$GET(ABSPCNT(ABSPPHRM,ABSPHRL,ABSPNAM,ABSPPIEN))+1
+49 SET ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL")=+$GET(ABSPTOT(ABSPPHRM,ABSPHRL,"TOTAL"))+1
+50 IF ($GET(ABSPPAT(ABSPHRNN))=1)
SET ABSPTOT(ABSPPHRM,"TOTAL")=$GET(ABSPTOT(ABSPPHRM,"TOTAL"))+1
+51 IF ($GET(ABSPDPT(ABSPDPT))=1)
SET ABSPTOT("TOTAL")=$GET(ABSPTOT("TOTAL"))+1
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+52 QUIT
+53 ;
+54 ;OIT/CAS/RCS 091213 Patch 46 Move subroutines
BDT() ;ENTER BEGINING DATE
+1 NEW ABSPBDT,DIR,X1,X
+2 WRITE !
+3 KILL DIR
+4 SET DIR(0)="DEX"
+5 SET DIR("A")="Enter Beginning Prescription Release Date"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
QUIT -1
+8 SET ABSPBDT=+Y
+9 SET X1=ABSPBDT
DO C^%DTC
+10 QUIT X
EDT() ;ENTER END DATE
+1 NEW ABSPEDT,DIR,X1,X
+2 WRITE !
+3 KILL DIR
+4 SET DIR(0)="DEX"
+5 SET DIR("A")="Enter Ending Prescription Release Date"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
QUIT -1
+8 SET ABSPEDT=+Y
+9 SET X1=ABSPEDT
DO C^%DTC
+10 QUIT X
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
+1 NEW DIC,X,Y
+2 SET DIC="^ABSP(9002313.56,"
+3 SET DIC(0)="AEMQVZ"
+4 SET DIC("A")="Please Select a Pharmacy or leave blank for ALL: "
+5 DO ^DIC
KILL DIC
+6 IF X[U
QUIT -1
+7 IF Y=-1
SET ABSPPPHM="ALL"
+8 IF Y>-1
SET ABSPPPHM=$PIECE(Y,U,1)
SET ABSPPHMN=$PIECE(Y,U,2)
+9 QUIT 1
DEVSEL ; SELECT DEVICE
+1 NEW ABSPSTOP
+2 SET ABSPSTOP=0
+3 DO ^%ZIS
+4 IF POP
Begin DoDot:1
+5 DO ^%ZIS
+6 QUIT
End DoDot:1
+7 IF $DATA(DUOUT)
Begin DoDot:1
+8 DO ZEND^ABSPOSRZ
+9 SET ABSPSTOP=1
+10 QUIT
End DoDot:1
+11 IF ABSPSTOP
QUIT
+12 IF POP
Begin DoDot:1
+13 WRITE "DEVICE UNAVAILABLE"
GOTO DEVSEL
End DoDot:1
+14 QUIT
