- IBDFN12 ;ALB/CJM - ENCOUNTER FORM - SELECTORS ;05/10/95
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**12,38,40,51,63**;APR 24, 1997;Build 80
- ;
- ;
- LOOKUP(FILE,SCREEN,X,NODE) ;
- ; -- lookup X in file using SCREEN
- ; -- kills X if lookup not successful, else sets X to the ien and returns NODE as the 0 node
- ; -- pass X and NODE by reference
- ;
- I +$G(FILE)<1 K X Q
- N Y
- S (NODE,Y)=""
- K DIC S DIC=FILE,DIC("S")=SCREEN
- S DIC(0)="EMQZ"
- I $D(^DIC(FILE)) D ^DIC K DIC
- I +Y>0 D
- .S X=Y,NODE=Y(0)
- E K X
- Q
- ;
- SLCTCPT(X) ;for CPT codes
- ;pass X by reference
- ;example of use: D SLCTCPT^IBDFN12(.X)
- ;
- N NODE,SCRN
- ;;D LOOKUP(81,"I '$P(^(0),U,4)",.X,.NODE)
- ;
- ;List only active code. (CSV)
- S SCRN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;Check status for CPT (CSV)
- D LOOKUP(81,SCRN,.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^",2),(IBID,X)=$P(NODE,"^",1)
- Q
- ;
- SLCTDX10(X) ;
- ;Get ICD-10 code.
- N IBDCODE
- I $G(X)="" K X Q
- I X["?" D INPHLP^IBDLXDG K X Q
- D SETPARAM^IBDLXDG(.IBDPARAM)
- S IBDCODE=$$LEXICD10^IBDLXDG(X,$$ICD10DT^IBDUTICD(DT),.IBDPARAM)
- I IBDCODE="" W !!,IBDPARAM("NO DATA FOUND"),!,IBDPARAM("NO DATA FOUND 2"),! K X Q
- I IBDCODE=-1!(IBDCODE=-2)!(IBDCODE=-3)!(IBDCODE=-4) K X Q ;Timed out or was aborted.
- S X=$P($P(IBDCODE,U),";",2)
- ;
- Q
- SLCTDX(X) ;for ICD9 diagnosis codes
- ;pass X by reference
- ;example of use: D SLCTICD^IBDFN12(.X)
- ;
- N NODE,SCRN
- ;;D LOOKUP(80,"I '$P(^(0),U,9)",.X,.NODE)
- ;
- ;List only active code. (CSV)
- S SCRN="I $P($$ICDDX^ICDCODE(Y),U,10)=1" ;Check status for ICD (CSV)
- D LOOKUP(80,SCRN,.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^",3),(IBID,X)=$P(NODE,"^",1)
- Q
- ;
- SLCTVST(X) ;for VISIT TYPE codes
- ;pass X by reference
- ;example of use: D SLCTVST^IBDFN12(.X)
- ;
- N NODE,SCREEN
- ;;D LOOKUP(357.69,"I '$P(^(0),U,4)",.X,.NODE)
- ;
- ;List only active code. (CSV)
- S SCRN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;Check status for CPT (CSV)
- D LOOKUP(357.69,SCRN,.X,.NODE)
- ;
- ;; --change to api cpt ; dhh
- I $G(X) S NODE=$$CPT^ICPTCOD(+NODE),NODE=$G(NODE),(IBID,X)=$P(NODE,"^",2),IBLABEL=$P(NODE,"^",3)
- Q
- ;
- SLCTED(X) ;for Education Topics
- ;pass X by reference
- ;example of use: D SLCTED^IBDFN12(.X)
- ;
- N NODE
- D LOOKUP(9999999.09,"",.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^"),IBID=+X,X=IBLABEL
- Q
- ;
- SLCTIMM(X) ;for Immunizations
- ;pass X by reference
- ;example of use: D SLCTIMM^IBDFN12(.X)
- ;
- N NODE
- D LOOKUP(9999999.14,"",.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^",2),IBID=+X,X=IBLABEL
- Q
- ;
- SLCTEX(X) ;for Exams
- ;pass X by reference
- ;example of use: D SLCTEX^IBDFN12(.X)
- ;
- N NODE
- D LOOKUP(9999999.15,"",.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^"),IBID=+X,X=IBLABEL
- Q
- ;
- SLCTSKN(X) ;for Skin Tests
- ;pass X by reference
- ;example of use: D SLCTSKN^IBDFN12(.X)
- ;
- N NODE
- D LOOKUP(9999999.28,"",.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^"),IBID=+X,X=IBLABEL
- Q
- ;
- SLCTHF(X) ;for Health Factors
- ;pass X by reference
- ;example of use: D SLCTHF^IBDFN12(.X)
- ;
- N NODE
- D LOOKUP(9999999.64,"I $P(^(0),U,10)=""F"",'$P(^(0),U,11)",.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^"),IBID=+X,X=IBLABEL
- Q
- SLCTTR(X) ;for Treatments
- ;pass X by reference
- ;example of use: D SLCTTR^IBDFN12(.X)
- ;
- N NODE
- D LOOKUP(9999999.17,"",.X,.NODE)
- I $D(X) S IBLABEL=$P(NODE,"^"),IBID=+X,X=IBLABEL
- Q
- ;
- SLCTYN(X) ;for selecting YES or NO
- ;
- I "Yy"[$E(X) S X="YES",IBID=1 Q
- I "Nn"[$E(X) S X="NO",IBID=0 Q
- W "Enter YES or NO."
- K X
- Q
- ;
- SLCTCLS(PI,X) ;for visit classification
- ;pass X by reference
- ;*NOTE: if interactive sets IBQUAL to the qualifier, IBLABEL to the recommended label, for use in the input template
- ;example of use: D INPUTCLS^IBDFN12(PI,.X)
- ;
- N NODE
- D LOOKUP(357.98,"I $$DQGOOD^IBDFU9(PI,Y)",.X,.NODE)
- I $D(X) S IBID="",IBLABEL=$P(NODE,"^",3),IBQUAL=+X,X=$P(NODE,"^")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFN12 3833 printed Feb 19, 2025@00:19:15 Page 2
- IBDFN12 ;ALB/CJM - ENCOUNTER FORM - SELECTORS ;05/10/95
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**12,38,40,51,63**;APR 24, 1997;Build 80
- +2 ;
- +3 ;
- LOOKUP(FILE,SCREEN,X,NODE) ;
- +1 ; -- lookup X in file using SCREEN
- +2 ; -- kills X if lookup not successful, else sets X to the ien and returns NODE as the 0 node
- +3 ; -- pass X and NODE by reference
- +4 ;
- +5 IF +$GET(FILE)<1
- KILL X
- QUIT
- +6 NEW Y
- +7 SET (NODE,Y)=""
- +8 KILL DIC
- SET DIC=FILE
- SET DIC("S")=SCREEN
- +9 SET DIC(0)="EMQZ"
- +10 IF $DATA(^DIC(FILE))
- DO ^DIC
- KILL DIC
- +11 IF +Y>0
- Begin DoDot:1
- +12 SET X=Y
- SET NODE=Y(0)
- End DoDot:1
- +13 IF '$TEST
- KILL X
- +14 QUIT
- +15 ;
- SLCTCPT(X) ;for CPT codes
- +1 ;pass X by reference
- +2 ;example of use: D SLCTCPT^IBDFN12(.X)
- +3 ;
- +4 NEW NODE,SCRN
- +5 ;;D LOOKUP(81,"I '$P(^(0),U,4)",.X,.NODE)
- +6 ;
- +7 ;List only active code. (CSV)
- +8 ;Check status for CPT (CSV)
- SET SCRN="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +9 DO LOOKUP(81,SCRN,.X,.NODE)
- +10 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^",2)
- SET (IBID,X)=$PIECE(NODE,"^",1)
- +11 QUIT
- +12 ;
- SLCTDX10(X) ;
- +1 ;Get ICD-10 code.
- +2 NEW IBDCODE
- +3 IF $GET(X)=""
- KILL X
- QUIT
- +4 IF X["?"
- DO INPHLP^IBDLXDG
- KILL X
- QUIT
- +5 DO SETPARAM^IBDLXDG(.IBDPARAM)
- +6 SET IBDCODE=$$LEXICD10^IBDLXDG(X,$$ICD10DT^IBDUTICD(DT),.IBDPARAM)
- +7 IF IBDCODE=""
- WRITE !!,IBDPARAM("NO DATA FOUND"),!,IBDPARAM("NO DATA FOUND 2"),!
- KILL X
- QUIT
- +8 ;Timed out or was aborted.
- IF IBDCODE=-1!(IBDCODE=-2)!(IBDCODE=-3)!(IBDCODE=-4)
- KILL X
- QUIT
- +9 SET X=$PIECE($PIECE(IBDCODE,U),";",2)
- +10 ;
- +11 QUIT
- SLCTDX(X) ;for ICD9 diagnosis codes
- +1 ;pass X by reference
- +2 ;example of use: D SLCTICD^IBDFN12(.X)
- +3 ;
- +4 NEW NODE,SCRN
- +5 ;;D LOOKUP(80,"I '$P(^(0),U,9)",.X,.NODE)
- +6 ;
- +7 ;List only active code. (CSV)
- +8 ;Check status for ICD (CSV)
- SET SCRN="I $P($$ICDDX^ICDCODE(Y),U,10)=1"
- +9 DO LOOKUP(80,SCRN,.X,.NODE)
- +10 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^",3)
- SET (IBID,X)=$PIECE(NODE,"^",1)
- +11 QUIT
- +12 ;
- SLCTVST(X) ;for VISIT TYPE codes
- +1 ;pass X by reference
- +2 ;example of use: D SLCTVST^IBDFN12(.X)
- +3 ;
- +4 NEW NODE,SCREEN
- +5 ;;D LOOKUP(357.69,"I '$P(^(0),U,4)",.X,.NODE)
- +6 ;
- +7 ;List only active code. (CSV)
- +8 ;Check status for CPT (CSV)
- SET SCRN="I $P($$CPT^ICPTCOD(Y),U,7)=1"
- +9 DO LOOKUP(357.69,SCRN,.X,.NODE)
- +10 ;
- +11 ;; --change to api cpt ; dhh
- +12 IF $GET(X)
- SET NODE=$$CPT^ICPTCOD(+NODE)
- SET NODE=$GET(NODE)
- SET (IBID,X)=$PIECE(NODE,"^",2)
- SET IBLABEL=$PIECE(NODE,"^",3)
- +13 QUIT
- +14 ;
- SLCTED(X) ;for Education Topics
- +1 ;pass X by reference
- +2 ;example of use: D SLCTED^IBDFN12(.X)
- +3 ;
- +4 NEW NODE
- +5 DO LOOKUP(9999999.09,"",.X,.NODE)
- +6 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^")
- SET IBID=+X
- SET X=IBLABEL
- +7 QUIT
- +8 ;
- SLCTIMM(X) ;for Immunizations
- +1 ;pass X by reference
- +2 ;example of use: D SLCTIMM^IBDFN12(.X)
- +3 ;
- +4 NEW NODE
- +5 DO LOOKUP(9999999.14,"",.X,.NODE)
- +6 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^",2)
- SET IBID=+X
- SET X=IBLABEL
- +7 QUIT
- +8 ;
- SLCTEX(X) ;for Exams
- +1 ;pass X by reference
- +2 ;example of use: D SLCTEX^IBDFN12(.X)
- +3 ;
- +4 NEW NODE
- +5 DO LOOKUP(9999999.15,"",.X,.NODE)
- +6 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^")
- SET IBID=+X
- SET X=IBLABEL
- +7 QUIT
- +8 ;
- SLCTSKN(X) ;for Skin Tests
- +1 ;pass X by reference
- +2 ;example of use: D SLCTSKN^IBDFN12(.X)
- +3 ;
- +4 NEW NODE
- +5 DO LOOKUP(9999999.28,"",.X,.NODE)
- +6 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^")
- SET IBID=+X
- SET X=IBLABEL
- +7 QUIT
- +8 ;
- SLCTHF(X) ;for Health Factors
- +1 ;pass X by reference
- +2 ;example of use: D SLCTHF^IBDFN12(.X)
- +3 ;
- +4 NEW NODE
- +5 DO LOOKUP(9999999.64,"I $P(^(0),U,10)=""F"",'$P(^(0),U,11)",.X,.NODE)
- +6 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^")
- SET IBID=+X
- SET X=IBLABEL
- +7 QUIT
- SLCTTR(X) ;for Treatments
- +1 ;pass X by reference
- +2 ;example of use: D SLCTTR^IBDFN12(.X)
- +3 ;
- +4 NEW NODE
- +5 DO LOOKUP(9999999.17,"",.X,.NODE)
- +6 IF $DATA(X)
- SET IBLABEL=$PIECE(NODE,"^")
- SET IBID=+X
- SET X=IBLABEL
- +7 QUIT
- +8 ;
- SLCTYN(X) ;for selecting YES or NO
- +1 ;
- +2 IF "Yy"[$EXTRACT(X)
- SET X="YES"
- SET IBID=1
- QUIT
- +3 IF "Nn"[$EXTRACT(X)
- SET X="NO"
- SET IBID=0
- QUIT
- +4 WRITE "Enter YES or NO."
- +5 KILL X
- +6 QUIT
- +7 ;
- SLCTCLS(PI,X) ;for visit classification
- +1 ;pass X by reference
- +2 ;*NOTE: if interactive sets IBQUAL to the qualifier, IBLABEL to the recommended label, for use in the input template
- +3 ;example of use: D INPUTCLS^IBDFN12(PI,.X)
- +4 ;
- +5 NEW NODE
- +6 DO LOOKUP(357.98,"I $$DQGOOD^IBDFU9(PI,Y)",.X,.NODE)
- +7 IF $DATA(X)
- SET IBID=""
- SET IBLABEL=$PIECE(NODE,"^",3)
- SET IBQUAL=+X
- SET X=$PIECE(NODE,"^")
- +8 QUIT