- AQAOPV21 ; IHS/ORDC/LJF - PRINT QI CODES ;
- ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
- ;
- ;This routine lets a user select providers/persons/vendors to match
- ;the names with their corresponding QI code.
- ; Routine added with Enhancement #1
- ;
- ;-- Logic Flow:
- ; LOOP until user finishes with selection
- ; calls LOOKUP to dic call to appropriate file
- ; DEV to select print device
- ; PRINT loops thru selections
- ; use PERSON to print data for providers/persons
- ; use VENDOR to print data for chs vendors
- ; EXIT to clean up and quit
- ;
- D LOOKUP^AQAOHPRV ;intro text
- K AQAOARR ;make sure array is empty to start
- S AQAOX=0 ;flag for first time thru
- ;
- LOOP ; -- ask for names or qi codes until user is done
- K DIR W !! S DIR(0)="FO^3:50^I (X'?1""I."".E),(X'?1""C."".E) K X"
- S DIR("A")="Select "_$S(AQAOX:"ANOTHER ",1:"")_"NAME or QI CODE"
- S DIR("A")=DIR("A")_" (eg.: I.SMITH or C.345)"
- S DIR("?")="Enter Provider/Employee Name or QI Code."
- S DIR("?",1)="Use 'I.' as the prefix for an IHS Provider or Employee."
- S DIR("?",2)="Use 'C.' as the prefix for a CHS Provider."
- S DIR("?",3)="Examples:"
- S DIR("?",4)=" I.SMITH for IHS provider Dr. Joe Smith."
- S DIR("?",5)=" I.234 for IHS provider/employee with QI code I234."
- S DIR("?",6)=" C.ABC DIAGNOSTIC SRV for CHS provider by that name."
- S DIR("?",7)=" C.567 for CHS provider with QI code C567."
- S DIR("?",8)=" "
- D ^DIR I $D(DIRUT) D DEV Q
- ;
- S S=$S(Y?1"I.".E:"",1:"I $P(^(0),Y,5)=""""") ;code for dic(s)
- I Y?1"I.".E D LOOKUP(200,S,Y) S AQAOX=1 D LOOP Q
- I Y?1"C.".E D LOOKUP(9999999.11,S,Y) S AQAOX=1 D LOOP Q
- ;
- ;
- DEV ; -- SUBRTN to get print device and call print rtn
- I '$D(AQAOARR) D EXIT Q ;no one selected
- W !! S %ZIS="QP" D ^%ZIS
- I POP D EXIT Q
- I '$D(IO("Q")) D PRINT Q
- K IO("Q") S ZTRTN="PRINT^AQAOPV21",ZTDESC="SINGLE QI CODES"
- S ZTSAVE("AQAOARR(")="" 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
- D ^%ZISC D KILL^AQAOUTIL Q
- ;
- ;
- PRINT ;EP; -- loop thru user's selections
- U IO D INIT^AQAOUTIL S AQAOHCON="Provider"
- S AQAOTY="LISTING OF SELECTED QI CODES"
- D HEADING^AQAOUTIL,HEADING2
- ;
- F AQAOI="C","I" Q:AQAOSTOP=U D
- . S AQAOX=0
- . F S AQAOX=$O(AQAOARR(AQAOI,AQAOX)) Q:AQAOX="" Q:AQAOSTOP=U D
- .. I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HEADING2
- .. S X=$S(AQAOI="I":"PERSON",1:"VENDOR")_"(AQAOI,AQAOX)" D @X
- D EXIT
- Q
- ;
- ;
- PERSON(AQAOI,AQAOX) ;EP; -- SUBRTN to print provider/person data
- NEW AQAO
- D ENP^XBDIQ1(200,AQAOX,".01;8;53.5;9999999.039","AQAO(")
- W !?1,AQAOI,AQAOX
- W ?10,$E(AQAO(.01),1,25)
- I AQAO(53.5)]"" W ?40,"IHS ",$E(AQAO(53.5),1,20)
- E W ?40,"IHS ",$E(AQAO(8),1,20)
- I AQAO(9999999.039)]"" W " (",AQAO(9999999.039),")"
- Q
- ;
- ;
- VENDOR(AQAOI,AQAOX) ;EP; -- SUBRTN to print vendor data
- NEW AQAO
- D ENP^XBDIQ1(9999999.11,AQAOX,".01;1102.01","AQAO(")
- W !?1,AQAOI,AQAOX
- W ?10,$E(AQAO(.01),1,25),?40,"CHS "
- S X=$$VALI^XBDIQ1(9999999.11,AQAOX,1103) ;vendor type code
- I X W $E($$VAL^XBDIQ1(9999999.34,X,.02),1,25) ;vendor type name
- W:AQAO(1102.01)]"" " (",AQAO(1102.01),")"
- Q
- ;
- ;
- HEADING2 ;EP; -- SUBRTN to print second half of heading
- W ?14,"(Please forward any INACTIVE NAMES to the proper dept.)"
- W !,AQAOLIN2,!,"QI Code",?10,"Name",?40,"Description"
- W !,AQAOLINE,! Q
- ;
- ;
- LOOKUP(DIC,DICS,INPUT) ; -- SUBRTN to find prov/pers/vendr from user input
- NEW X,Y
- S DIC(0)="EQ",X=$P(INPUT,".",2) I +X S X="`"_X
- S:DICS]"" DIC("S")=DICS D ^DIC I Y=-1 W *7,"Try again",! Q
- S AQAOARR($E(INPUT,1),+Y)=""
- Q
- AQAOPV21 ; IHS/ORDC/LJF - PRINT QI CODES ;
- +1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
- +2 ;
- +3 ;This routine lets a user select providers/persons/vendors to match
- +4 ;the names with their corresponding QI code.
- +5 ; Routine added with Enhancement #1
- +6 ;
- +7 ;-- Logic Flow:
- +8 ; LOOP until user finishes with selection
- +9 ; calls LOOKUP to dic call to appropriate file
- +10 ; DEV to select print device
- +11 ; PRINT loops thru selections
- +12 ; use PERSON to print data for providers/persons
- +13 ; use VENDOR to print data for chs vendors
- +14 ; EXIT to clean up and quit
- +15 ;
- +16 ;intro text
- DO LOOKUP^AQAOHPRV
- +17 ;make sure array is empty to start
- KILL AQAOARR
- +18 ;flag for first time thru
- SET AQAOX=0
- +19 ;
- LOOP ; -- ask for names or qi codes until user is done
- +1 KILL DIR
- WRITE !!
- SET DIR(0)="FO^3:50^I (X'?1""I."".E),(X'?1""C."".E) K X"
- +2 SET DIR("A")="Select "_$SELECT(AQAOX:"ANOTHER ",1:"")_"NAME or QI CODE"
- +3 SET DIR("A")=DIR("A")_" (eg.: I.SMITH or C.345)"
- +4 SET DIR("?")="Enter Provider/Employee Name or QI Code."
- +5 SET DIR("?",1)="Use 'I.' as the prefix for an IHS Provider or Employee."
- +6 SET DIR("?",2)="Use 'C.' as the prefix for a CHS Provider."
- +7 SET DIR("?",3)="Examples:"
- +8 SET DIR("?",4)=" I.SMITH for IHS provider Dr. Joe Smith."
- +9 SET DIR("?",5)=" I.234 for IHS provider/employee with QI code I234."
- +10 SET DIR("?",6)=" C.ABC DIAGNOSTIC SRV for CHS provider by that name."
- +11 SET DIR("?",7)=" C.567 for CHS provider with QI code C567."
- +12 SET DIR("?",8)=" "
- +13 DO ^DIR
- IF $DATA(DIRUT)
- DO DEV
- QUIT
- +14 ;
- +15 ;code for dic(s)
- SET S=$SELECT(Y?1"I.".E:"",1:"I $P(^(0),Y,5)=""""")
- +16 IF Y?1"I.".E
- DO LOOKUP(200,S,Y)
- SET AQAOX=1
- DO LOOP
- QUIT
- +17 IF Y?1"C.".E
- DO LOOKUP(9999999.11,S,Y)
- SET AQAOX=1
- DO LOOP
- QUIT
- +18 ;
- +19 ;
- DEV ; -- SUBRTN to get print device and call print rtn
- +1 ;no one selected
- IF '$DATA(AQAOARR)
- DO EXIT
- QUIT
- +2 WRITE !!
- SET %ZIS="QP"
- DO ^%ZIS
- +3 IF POP
- DO EXIT
- QUIT
- +4 IF '$DATA(IO("Q"))
- DO PRINT
- QUIT
- +5 KILL IO("Q")
- SET ZTRTN="PRINT^AQAOPV21"
- SET ZTDESC="SINGLE QI CODES"
- +6 SET ZTSAVE("AQAOARR(")=""
- 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 DO ^%ZISC
- DO KILL^AQAOUTIL
- QUIT
- +3 ;
- +4 ;
- PRINT ;EP; -- loop thru user's selections
- +1 USE IO
- DO INIT^AQAOUTIL
- SET AQAOHCON="Provider"
- +2 SET AQAOTY="LISTING OF SELECTED QI CODES"
- +3 DO HEADING^AQAOUTIL
- DO HEADING2
- +4 ;
- +5 FOR AQAOI="C","I"
- IF AQAOSTOP=U
- QUIT
- Begin DoDot:1
- +6 SET AQAOX=0
- +7 FOR
- SET AQAOX=$ORDER(AQAOARR(AQAOI,AQAOX))
- IF AQAOX=""
- QUIT
- IF AQAOSTOP=U
- QUIT
- Begin DoDot:2
- +8 IF $Y>(IOSL-4)
- DO NEWPG^AQAOUTIL
- IF AQAOSTOP=U
- QUIT
- DO HEADING2
- +9 SET X=$SELECT(AQAOI="I":"PERSON",1:"VENDOR")_"(AQAOI,AQAOX)"
- DO @X
- End DoDot:2
- End DoDot:1
- +10 DO EXIT
- +11 QUIT
- +12 ;
- +13 ;
- PERSON(AQAOI,AQAOX) ;EP; -- SUBRTN to print provider/person data
- +1 NEW AQAO
- +2 DO ENP^XBDIQ1(200,AQAOX,".01;8;53.5;9999999.039","AQAO(")
- +3 WRITE !?1,AQAOI,AQAOX
- +4 WRITE ?10,$EXTRACT(AQAO(.01),1,25)
- +5 IF AQAO(53.5)]""
- WRITE ?40,"IHS ",$EXTRACT(AQAO(53.5),1,20)
- +6 IF '$TEST
- WRITE ?40,"IHS ",$EXTRACT(AQAO(8),1,20)
- +7 IF AQAO(9999999.039)]""
- WRITE " (",AQAO(9999999.039),")"
- +8 QUIT
- +9 ;
- +10 ;
- VENDOR(AQAOI,AQAOX) ;EP; -- SUBRTN to print vendor data
- +1 NEW AQAO
- +2 DO ENP^XBDIQ1(9999999.11,AQAOX,".01;1102.01","AQAO(")
- +3 WRITE !?1,AQAOI,AQAOX
- +4 WRITE ?10,$EXTRACT(AQAO(.01),1,25),?40,"CHS "
- +5 ;vendor type code
- SET X=$$VALI^XBDIQ1(9999999.11,AQAOX,1103)
- +6 ;vendor type name
- IF X
- WRITE $EXTRACT($$VAL^XBDIQ1(9999999.34,X,.02),1,25)
- +7 IF AQAO(1102.01)]""
- WRITE " (",AQAO(1102.01),")"
- +8 QUIT
- +9 ;
- +10 ;
- HEADING2 ;EP; -- SUBRTN to print second half of heading
- +1 WRITE ?14,"(Please forward any INACTIVE NAMES to the proper dept.)"
- +2 WRITE !,AQAOLIN2,!,"QI Code",?10,"Name",?40,"Description"
- +3 WRITE !,AQAOLINE,!
- QUIT
- +4 ;
- +5 ;
- LOOKUP(DIC,DICS,INPUT) ; -- SUBRTN to find prov/pers/vendr from user input
- +1 NEW X,Y
- +2 SET DIC(0)="EQ"
- SET X=$PIECE(INPUT,".",2)
- IF +X
- SET X="`"_X
- +3 IF DICS]""
- SET DIC("S")=DICS
- DO ^DIC
- IF Y=-1
- WRITE *7,"Try again",!
- QUIT
- +4 SET AQAOARR($EXTRACT(INPUT,1),+Y)=""
- +5 QUIT
