AQAOPV23 ; IHS/ORDC/LJF - PRINT QI CODES BY CLASS/TYPE ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This routine prints listing of CHS or IHS providers by CHS provider
;type or IHS provider class.
;Routine added with Version 1.01
;
;-- Logic Flow:
; ASK to ask user which groups to include (chs or ihs providers)
; DEV to select print device
; PRINT checks groups selected:
; if ihs provider selected:
; use PERSON^AQAOPV21 to print by class
; if chs provider selected:
; use VENDOR^AQAOPV21 to print by type
; EXIT to clean up and quit
;
D BYCLASS^AQAOHPRV ;intro text
;
ASK ; -- ask for groups to include
K DIR W !! S DIR(0)="NO^1:2"
S DIR("A")="Select Which Group you want in report"
S DIR("A",1)=" 1. IHS Providers by CLASS"
S DIR("A",2)=" 2. CHS Providers by Type"
S DIR("A",3)=" "
D ^DIR I $D(DIRUT) D EXIT Q
S AQAOSEL=Y
;
WHICH ; -- which class or types or all
K DIR S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Do you wish to print for ALL "_$S(AQAOSEL=1:"Classes",1:"Types")
D ^DIR I $D(DIRUT) D ASK Q
I Y=1 S AQAOSEL1="ALL" D DEV Q
;
K DIC S DIC(0)="AEMQZ",DIC=$S(AQAOSEL=1:7,1:9999999.34)
S DIC("A")="Which "_$S(AQAOSEL=1:"CLASS",1:"TYPE")_"? "
D ^DIC I Y<1 D WHICH Q
S AQAOSEL1=$P(Y,U,2)
;
;
DEV ; -- SUBRTN to get print device and call print rtn
W !! S %ZIS="QP" D ^%ZIS
I POP D EXIT Q
I '$D(IO("Q")) D PRINT Q
K IO("Q") S ZTRTN="PRINT^AQAOPV23",ZTDESC="QI CODES BY NUMBER"
F I="AQAOSEL","AQAOSEL1" S ZTSAVE(I)=""
D ^%ZTLOAD K ZTSK D ^%ZISC
D PRTOPT^AQAOVAR D EXIT Q
;
;
EXIT ; -- SUBRTN for eoj
I '$D(ZTQUEUED),(IOST["C-") D PRTOPT^AQAOVAR ;ask to hit return
K ^TMP("AQAOPV23",$J)
D ^%ZISC K AQAOSEL D KILL^AQAOUTIL Q
;
;
PRINT ;EP; -- check user selections and call proper subrtn
U IO K ^TMP("AQAOPV23",$J)
D INIT^AQAOUTIL S AQAOHCON="Provider"
S AQAOTY="QI CODES BY "_$S(AQAOSEL=1:"CLASS",1:"TYPE")
;
I AQAOSEL=1 D PERSON
I AQAOSEL=2 D VENDOR
D EXIT
Q
;
;
PERSON ; -- SUBRTN to print ihs provider data
NEW AQAOC,AQAOX,AQAOY,X,Y
S AQAON=0
F S AQAON=$O(^VA(200,"AK.PROVIDER",AQAON)) Q:AQAON="" Q:AQAOSTOP=U D
. S AQAOX=0
. F S AQAOX=$O(^VA(200,"AK.PROVIDER",AQAON,AQAOX)) Q:AQAOX="" Q:AQAOSTOP=U D
.. Q:'$D(^VA(200,AQAOX,0))
.. I $P($G(^VA(200,AQAOX,"PS")),U,4)]"",$P(^("PS"),U,4)'>DT Q ;inact
.. S X=$$VAL^XBDIQ1(200,AQAOX,53.5) S:X="" X="UNKNOWN"
.. I AQAOSEL1'="ALL",X'=AQAOSEL1 Q ;not for class selected
.. S ^TMP("AQAOPV23",$J,"IHS "_X,AQAON,AQAOX)=""
;
S AQAOC=0
F S AQAOC=$O(^TMP("AQAOPV23",$J,AQAOC)) Q:AQAOC="" Q:AQAOSTOP=U D
. D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HEADING2
. S AQAOY=0
. F S AQAOY=$O(^TMP("AQAOPV23",$J,AQAOC,AQAOY)) Q:AQAOY="" Q:AQAOSTOP=U D
.. S AQAOX=""
.. F S AQAOX=$O(^TMP("AQAOPV23",$J,AQAOC,AQAOY,AQAOX)) Q:AQAOX="" Q:AQAOSTOP=U D
... I $Y>(IOSL-3) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HEADING2
... D PERSON^AQAOPV21("I",AQAOX)
Q
;
VENDOR ; -- SUBRTN to print chs provider data
NEW AQAOT,AQAOX,AQAOY,X,Y
S AQAOX=0
F S AQAOX=$O(^AUTTVNDR(AQAOX)) Q:AQAOX'=+AQAOX Q:AQAOSTOP=U D
. Q:'$D(^AUTTVNDR(AQAOX,0))
. Q:$$VALI^XBDIQ1(9999999.11,AQAOX,.05) ;screen out inactives
. S X=$$VALI^XBDIQ1(9999999.11,AQAOX,1103) Q:X="" ;needs vendor type
. I AQAOSEL1'="ALL",X'=AQAOSEL1 Q ;not for type selected
. S X=$$VAL^XBDIQ1(9999999.34,X,.02)
. S Y=$$VAL^XBDIQ1(9999999.11,AQAOX,.01)
. S ^TMP("AQAOPV23",$J,"CHS "_X,Y,AQAOX)=""
;
S AQAOT=0
F S AQAOT=$O(^TMP("AQAOPV23",$J,AQAOT)) Q:AQAOT="" Q:AQAOSTOP=U D
. D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HEADING2
. S AQAOY=0
. F S AQAOY=$O(^TMP("AQAOPV23",$J,AQAOT,AQAOY)) Q:AQAOY="" Q:AQAOSTOP=U D
.. S AQAOX=0
.. F S AQAOX=$O(^TMP("AQAOPV23",$J,AQAOT,AQAOY,AQAOX)) Q:AQAOX="" Q:AQAOSTOP=U D
... I $Y>(IOSL-3) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HEADING2
... D VENDOR^AQAOPV21("C",AQAOX)
Q
;
;
;
HEADING2 ; -- SUBRTN to print second half of heading
D HEADING2^AQAOPV21 Q
AQAOPV23 ; IHS/ORDC/LJF - PRINT QI CODES BY CLASS/TYPE ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This routine prints listing of CHS or IHS providers by CHS provider
+4 ;type or IHS provider class.
+5 ;Routine added with Version 1.01
+6 ;
+7 ;-- Logic Flow:
+8 ; ASK to ask user which groups to include (chs or ihs providers)
+9 ; DEV to select print device
+10 ; PRINT checks groups selected:
+11 ; if ihs provider selected:
+12 ; use PERSON^AQAOPV21 to print by class
+13 ; if chs provider selected:
+14 ; use VENDOR^AQAOPV21 to print by type
+15 ; EXIT to clean up and quit
+16 ;
+17 ;intro text
DO BYCLASS^AQAOHPRV
+18 ;
ASK ; -- ask for groups to include
+1 KILL DIR
WRITE !!
SET DIR(0)="NO^1:2"
+2 SET DIR("A")="Select Which Group you want in report"
+3 SET DIR("A",1)=" 1. IHS Providers by CLASS"
+4 SET DIR("A",2)=" 2. CHS Providers by Type"
+5 SET DIR("A",3)=" "
+6 DO ^DIR
IF $DATA(DIRUT)
DO EXIT
QUIT
+7 SET AQAOSEL=Y
+8 ;
WHICH ; -- which class or types or all
+1 KILL DIR
SET DIR(0)="YO"
SET DIR("B")="NO"
+2 SET DIR("A")="Do you wish to print for ALL "_$SELECT(AQAOSEL=1:"Classes",1:"Types")
+3 DO ^DIR
IF $DATA(DIRUT)
DO ASK
QUIT
+4 IF Y=1
SET AQAOSEL1="ALL"
DO DEV
QUIT
+5 ;
+6 KILL DIC
SET DIC(0)="AEMQZ"
SET DIC=$SELECT(AQAOSEL=1:7,1:9999999.34)
+7 SET DIC("A")="Which "_$SELECT(AQAOSEL=1:"CLASS",1:"TYPE")_"? "
+8 DO ^DIC
IF Y<1
DO WHICH
QUIT
+9 SET AQAOSEL1=$PIECE(Y,U,2)
+10 ;
+11 ;
DEV ; -- SUBRTN to get print device and call print rtn
+1 WRITE !!
SET %ZIS="QP"
DO ^%ZIS
+2 IF POP
DO EXIT
QUIT
+3 IF '$DATA(IO("Q"))
DO PRINT
QUIT
+4 KILL IO("Q")
SET ZTRTN="PRINT^AQAOPV23"
SET ZTDESC="QI CODES BY NUMBER"
+5 FOR I="AQAOSEL","AQAOSEL1"
SET ZTSAVE(I)=""
+6 DO ^%ZTLOAD
KILL ZTSK
DO ^%ZISC
+7 DO PRTOPT^AQAOVAR
DO EXIT
QUIT
+8 ;
+9 ;
EXIT ; -- SUBRTN for eoj
+1 ;ask to hit return
IF '$DATA(ZTQUEUED)
IF (IOST["C-")
DO PRTOPT^AQAOVAR
+2 KILL ^TMP("AQAOPV23",$JOB)
+3 DO ^%ZISC
KILL AQAOSEL
DO KILL^AQAOUTIL
QUIT
+4 ;
+5 ;
PRINT ;EP; -- check user selections and call proper subrtn
+1 USE IO
KILL ^TMP("AQAOPV23",$JOB)
+2 DO INIT^AQAOUTIL
SET AQAOHCON="Provider"
+3 SET AQAOTY="QI CODES BY "_$SELECT(AQAOSEL=1:"CLASS",1:"TYPE")
+4 ;
+5 IF AQAOSEL=1
DO PERSON
+6 IF AQAOSEL=2
DO VENDOR
+7 DO EXIT
+8 QUIT
+9 ;
+10 ;
PERSON ; -- SUBRTN to print ihs provider data
+1 NEW AQAOC,AQAOX,AQAOY,X,Y
+2 SET AQAON=0
+3 FOR
SET AQAON=$ORDER(^VA(200,"AK.PROVIDER",AQAON))
IF AQAON=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 SET AQAOX=0
+5 FOR
SET AQAOX=$ORDER(^VA(200,"AK.PROVIDER",AQAON,AQAOX))
IF AQAOX=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+6 IF '$DATA(^VA(200,AQAOX,0))
QUIT
+7 ;inact
IF $PIECE($GET(^VA(200,AQAOX,"PS")),U,4)]""
IF $PIECE(^("PS"),U,4)'>DT
QUIT
+8 SET X=$$VAL^XBDIQ1(200,AQAOX,53.5)
IF X=""
SET X="UNKNOWN"
+9 ;not for class selected
IF AQAOSEL1'="ALL"
IF X'=AQAOSEL1
QUIT
+10 SET ^TMP("AQAOPV23",$JOB,"IHS "_X,AQAON,AQAOX)=""
End DoDot:2
End DoDot:1
+11 ;
+12 SET AQAOC=0
+13 FOR
SET AQAOC=$ORDER(^TMP("AQAOPV23",$JOB,AQAOC))
IF AQAOC=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+14 DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HEADING2
+15 SET AQAOY=0
+16 FOR
SET AQAOY=$ORDER(^TMP("AQAOPV23",$JOB,AQAOC,AQAOY))
IF AQAOY=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+17 SET AQAOX=""
+18 FOR
SET AQAOX=$ORDER(^TMP("AQAOPV23",$JOB,AQAOC,AQAOY,AQAOX))
IF AQAOX=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:3
+19 IF $Y>(IOSL-3)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HEADING2
+20 DO PERSON^AQAOPV21("I",AQAOX)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
VENDOR ; -- SUBRTN to print chs provider data
+1 NEW AQAOT,AQAOX,AQAOY,X,Y
+2 SET AQAOX=0
+3 FOR
SET AQAOX=$ORDER(^AUTTVNDR(AQAOX))
IF AQAOX'=+AQAOX
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUTTVNDR(AQAOX,0))
QUIT
+5 ;screen out inactives
IF $$VALI^XBDIQ1(9999999.11,AQAOX,.05)
QUIT
+6 ;needs vendor type
SET X=$$VALI^XBDIQ1(9999999.11,AQAOX,1103)
IF X=""
QUIT
+7 ;not for type selected
IF AQAOSEL1'="ALL"
IF X'=AQAOSEL1
QUIT
+8 SET X=$$VAL^XBDIQ1(9999999.34,X,.02)
+9 SET Y=$$VAL^XBDIQ1(9999999.11,AQAOX,.01)
+10 SET ^TMP("AQAOPV23",$JOB,"CHS "_X,Y,AQAOX)=""
End DoDot:1
+11 ;
+12 SET AQAOT=0
+13 FOR
SET AQAOT=$ORDER(^TMP("AQAOPV23",$JOB,AQAOT))
IF AQAOT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+14 DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HEADING2
+15 SET AQAOY=0
+16 FOR
SET AQAOY=$ORDER(^TMP("AQAOPV23",$JOB,AQAOT,AQAOY))
IF AQAOY=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+17 SET AQAOX=0
+18 FOR
SET AQAOX=$ORDER(^TMP("AQAOPV23",$JOB,AQAOT,AQAOY,AQAOX))
IF AQAOX=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:3
+19 IF $Y>(IOSL-3)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HEADING2
+20 DO VENDOR^AQAOPV21("C",AQAOX)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;
+24 ;
HEADING2 ; -- SUBRTN to print second half of heading
+1 DO HEADING2^AQAOPV21
QUIT
