- 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
