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
