- IBDFRPC6 ;ALB/AAS - AICS Pass data to PCE, Broker Call ; 24-FEB-96
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25,38**;APR 24, 1997
- ;
- FINDALL(RESULT) ; -- loop through all entries for data
- ; -- called from ibdfrpc5, ONLY call if data in ^tmp
- N IBDI
- S RESULT(0)="The following data was found: "
- F IBDI="VST","PRV","POV","CPT","HF","PED","XAM","SK","IMM","TRT" D @(IBDI)
- K ^TMP("PXKENC",$J)
- Q
- ;
- PRV ; -- Expand Provider Entry
- N IBDY,IBDJ,IEN,X,Y
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"PRV",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"PRV",IEN)
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=$S($P(Y,"^",4)="P":"Primary",1:"Secondary")_"^Provider^"_$P($G(^VA(200,+Y,0)),"^")
- ...S $P(X,"^",5)=$$SOURCE(9000010.06)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=$S($P(Y,"^",4)="P":" Primary",1:" Secondary")_" Provider: "_$P($G(^VA(200,+Y,0)),"^")
- ..D INC(X,.CNT)
- Q
- ;
- POV ; -- Expand POV entry, (9000010.07)
- N IBDY,IBDJ,IEN,X,Y
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"POV",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"POV",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=$S($P(Y,"^",12)="P":" Primary",1:"Secondary")_" Diagnosis: "
- ...S X=X_$E($P($G(^ICD9(+Y,0)),"^")_" ",1,6)_" - "
- ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.07,.04,"",$P(Y,"^",4))
- ...ELSE S X=X_$E($G(^ICD9(+Y,1)),1,80)
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=$S($P(Y,"^",12)="P":"Primary",1:"Secondary")_"^Diagnosis^"
- ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.07,.04,"",$P(Y,"^",4))
- ...ELSE S X=X_$E($G(^ICD9(+Y,1)),1,80)
- ...S X=X_"^"_$E($P($G(^ICD9(+Y,0)),"^")_" ",1,6)
- ...S $P(X,"^",5)=$$SOURCE(9000010.07)
- ..D INC(X,.CNT)
- Q
- ;
- CPT ; -- Expand CPT entry
- N IBDY,IBDJ,IEN,QUAN,X,Y,CODE
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"CPT",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"CPT",IEN)
- ..S QUAN=$P(Y,"^",16)
- ..;;-----change to api cpt; dhh
- ..S CODE=$$CPT^ICPTCOD(+Y)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...I +CODE=-1 S CODE=""
- ...E S CODE=$P(CODE,U,2)
- ...S X=" Procedure: "_CODE_" - "
- ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.18,.04,"",$P(Y,"^",4))
- ...ELSE S X=X_$P(CODE,"^",3)
- ...S X=X_" Quantity: "_QUAN
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X="^Procedure^"
- ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.18,.04,"",$P(Y,"^",4))
- ...ELSE S X=X_$P(CODE,"^",3)
- ...S X=X_"^"_$P(CODE,"^",2)_"^"_$$SOURCE(9000010.18)_"^"_QUAN
- ..D INC(X,.CNT)
- Q
- ;
- HF ; -- Expand Health Factors
- N IBDY,IBDJ,IEN,X,Y,Z
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"HF",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"HF",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Health Factor: "_$E($$EXTERNAL^DILFD(9000010.23,.01,"",+Y)_L,1,25)
- ...I $P(Y,"^",4)'="" S X=X_" Severity="_$$EXTERNAL^DILFD(9000010.23,.04,"",$P(Y,"^",4))
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=""
- ...I $P(Y,"^",4)'="" S X=$$EXTERNAL^DILFD(9000010.23,.04,"",$P(Y,"^",4))
- ...S X=X_"^Health Factor^"_$E($$EXTERNAL^DILFD(9000010.23,.01,"",+Y),1,25)
- ...S $P(X,"^",5)=$$SOURCE(9000010.23)
- ..D INC(X,.CNT)
- Q
- ;
- IMM ; -- Expand Immunizations
- N IBDY,IBDJ,IEN,X,Y
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"IMM",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"IMM",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Immunization: "_$$EXTERNAL^DILFD(9000010.11,.01,"",+Y)
- ...I $P(Y,"^",7) S X=X_" Contraindicated!"
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X="" I $P(Y,"^",7) S X="Contraindicated"
- ...S X=X_"^Immunization^"_$$EXTERNAL^DILFD(9000010.11,.01,"",+Y)
- ...S $P(X,"^",5)=$$SOURCE(9000010.11)
- ..D INC(X,.CNT)
- Q
- ;
- PED ; -- Expand Patient Education
- N IBDY,IBDJ,IEN,X,Y
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"PED",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"PED",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Education Topic: "_$E($$EXTERNAL^DILFD(9000010.16,.01,"",+Y)_L,1,25)
- ...I $P(Y,"^",6)'="" S X=X_" Understanding="_$$EXTERNAL^DILFD(9000010.16,.06,"",$P(Y,"^",6))
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=""
- ...I $P(Y,"^",6)'="" S X=$$EXTERNAL^DILFD(9000010.16,.06,"",$P(Y,"^",6))
- ...S X=X_"^Education Topic^"_$E($$EXTERNAL^DILFD(9000010.16,.01,"",+Y),1,25)
- ...S $P(X,"^",5)=$$SOURCE(9000010.16)
- ..D INC(X,.CNT)
- Q
- ;
- SK ; -- Expand Skin Tests
- N IBDY,IBDJ,IEN,X,Y,Z
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"SK",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"SK",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Skin Test: "_$E($$EXTERNAL^DILFD(9000010.12,.01,"",+Y)_L,1,25)
- ...I $P(Y,"^",4)'="" S X=X_" Result="_$$EXTERNAL^DILFD(9000010.12,.04,"",$P(Y,"^",4))
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=$$EXTERNAL^DILFD(9000010.12,.04,"",$P(Y,"^",4))
- ...S X=X_"^Skin Test^"_$E($$EXTERNAL^DILFD(9000010.12,.01,"",+Y),1,25)
- ...S $P(X,"^",5)=$$SOURCE(9000010.12)
- ..D INC(X,.CNT)
- Q
- ;
- TRT ; -- Expand Treatments
- N IBDY,IBDJ,IEN,X,Y,TRT
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"TRT",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"TRT",IEN)
- ..S TRT=$$EXTERNAL^DILFD(9000010.15,.01,"",+Y)
- ..I TRT="OTHER" S TRT=$$EXTERNAL^DILFD(9000010.15,.06,"",$P(Y,"^",6))
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Treatment: "_TRT
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X="^Treatment^"_TRT
- ...S $P(X,"^",5)=$$SOURCE(9000010.15)
- ..D INC(X,.CNT)
- Q
- ;
- XAM ; -- Expand Exams
- N IBDY,IBDJ,IEN,X,Y
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"XAM",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"XAM",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Exam: "_$E($$EXTERNAL^DILFD(9000010.13,.01,"",+Y)_L,1,25)
- ...S X=X_" Result="_$$EXTERNAL^DILFD(9000010.13,.04,"",$P(Y,"^",4))
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=$$EXTERNAL^DILFD(9000010.13,.04,"",$P(Y,"^",4))
- ...S X=X_"^Exam^"_$E($$EXTERNAL^DILFD(9000010.13,.01,"",+Y),1,25)
- ...S $P(X,"^",5)=$$SOURCE(9000010.13)
- ..D INC(X,.CNT)
- Q
- ;
- VST ; -- Expand visit entry
- N IBDY,IBDJ,IBDZ,IEN,X,Y
- F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
- .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"VST",IEN)) Q:'IEN D
- ..D GETY(.Y,IBDY,"VST",IEN)
- ..I '$G(IBDATA("UNFORMAT")) D
- ...S X=" Encounter Info: "_$$EXTERNAL^DILFD(9000010,.22,"",$P(Y,"^",22))_" - "_$$FMTE^XLFDT(+Y)_" - "_$$EXTERNAL^DILFD(9000010,15003,"",$P(Y(150),"^",3))_" Encounter"
- ...D INC(X,.CNT)
- ...S X=""
- ...S X=$$SOURCE(9000010) I X'="" S X=$E(L,1,22)_"Source - "_X
- ...I $P(Y(800),"^",1)'="" S X=X_", SC := "_$S($P(Y(800),"^",1):"Yes",1:"No")
- ...I $P(Y(800),"^",2)'="" S X=X_", AO:="_$S($P(Y(800),"^",2):"Yes",1:"No")
- ...I $P(Y(800),"^",3)'="" S X=X_", IR:="_$S($P(Y(800),"^",3):"Yes",1:"No")
- ...I $P(Y(800),"^",4)'="" S X=X_", EC:="_$S($P(Y(800),"^",4):"Yes",1:"No")
- ..;
- ..I $G(IBDATA("UNFORMAT")) D
- ...S X=$$EXTERNAL^DILFD(9000010,15003,"",$P(Y(150),"^",3))_"^Encounter^"
- ...S X=X_$$EXTERNAL^DILFD(9000010,.22,"",$P(Y,"^",22))_"^"_$$FMTE^XLFDT(+Y)_"^"
- ...S X=X_$$SOURCE(9000010)
- ...F IBDZ=1:1:4 I $P(Y(800),"^",IBDZ)'="" S $P(X,"^",(6+IBDZ))=$P(Y(800),"^",IBDZ)
- ..I X'="" D INC(X,.CNT)
- Q
- ;
- INC(X,CNT) ; -- increment results array
- S CNT=CNT+1
- S RESULT(CNT)=X
- Q
- ;
- GETY(Y,IBDY,TYPE,IEN) ; -- return y array
- S Y=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,0))
- S Y(150)=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,150))
- S Y(812)=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,812))
- I TYPE="VST" S Y(800)=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,800))
- Q
- ;
- SOURCE(FILE) ; -- return source of data
- N X S X=""
- I $P(Y(812),"^",3)'="" S X=$$EXTERNAL^DILFD(FILE,81203,"",$P(Y(812),"^",3))
- I X="",$P(Y(812),"^",2)'="" S X=$$EXTERNAL^DILFD(FILE,81202,"",$P(Y(812),"^",2))
- Q X
- ;
- TEST G TEST^IBDFRPC5
- TESTW G TESTW^IBDFRPC5
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFRPC6 8027 printed Jan 18, 2025@03:54:35 Page 2
- IBDFRPC6 ;ALB/AAS - AICS Pass data to PCE, Broker Call ; 24-FEB-96
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25,38**;APR 24, 1997
- +2 ;
- FINDALL(RESULT) ; -- loop through all entries for data
- +1 ; -- called from ibdfrpc5, ONLY call if data in ^tmp
- +2 NEW IBDI
- +3 SET RESULT(0)="The following data was found: "
- +4 FOR IBDI="VST","PRV","POV","CPT","HF","PED","XAM","SK","IMM","TRT"
- DO @(IBDI)
- +5 KILL ^TMP("PXKENC",$JOB)
- +6 QUIT
- +7 ;
- PRV ; -- Expand Provider Entry
- +1 NEW IBDY,IBDJ,IEN,X,Y
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"PRV",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"PRV",IEN)
- +5 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=$SELECT($PIECE(Y,"^",4)="P":"Primary",1:"Secondary")_"^Provider^"_$PIECE($GET(^VA(200,+Y,0)),"^")
- +7 SET $PIECE(X,"^",5)=$$SOURCE(9000010.06)
- End DoDot:3
- +8 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +9 SET X=$SELECT($PIECE(Y,"^",4)="P":" Primary",1:" Secondary")_" Provider: "_$PIECE($GET(^VA(200,+Y,0)),"^")
- End DoDot:3
- +10 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +11 QUIT
- +12 ;
- POV ; -- Expand POV entry, (9000010.07)
- +1 NEW IBDY,IBDJ,IEN,X,Y
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"POV",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"POV",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=$SELECT($PIECE(Y,"^",12)="P":" Primary",1:"Secondary")_" Diagnosis: "
- +7 SET X=X_$EXTRACT($PIECE($GET(^ICD9(+Y,0)),"^")_" ",1,6)_" - "
- +8 IF $PIECE(Y,"^",4)
- SET X=X_$$EXTERNAL^DILFD(9000010.07,.04,"",$PIECE(Y,"^",4))
- +9 IF '$TEST
- SET X=X_$EXTRACT($GET(^ICD9(+Y,1)),1,80)
- End DoDot:3
- +10 ;
- +11 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +12 SET X=$SELECT($PIECE(Y,"^",12)="P":"Primary",1:"Secondary")_"^Diagnosis^"
- +13 IF $PIECE(Y,"^",4)
- SET X=X_$$EXTERNAL^DILFD(9000010.07,.04,"",$PIECE(Y,"^",4))
- +14 IF '$TEST
- SET X=X_$EXTRACT($GET(^ICD9(+Y,1)),1,80)
- +15 SET X=X_"^"_$EXTRACT($PIECE($GET(^ICD9(+Y,0)),"^")_" ",1,6)
- +16 SET $PIECE(X,"^",5)=$$SOURCE(9000010.07)
- End DoDot:3
- +17 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +18 QUIT
- +19 ;
- CPT ; -- Expand CPT entry
- +1 NEW IBDY,IBDJ,IEN,QUAN,X,Y,CODE
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"CPT",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"CPT",IEN)
- +5 SET QUAN=$PIECE(Y,"^",16)
- +6 ;;-----change to api cpt; dhh
- +7 SET CODE=$$CPT^ICPTCOD(+Y)
- +8 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +9 IF +CODE=-1
- SET CODE=""
- +10 IF '$TEST
- SET CODE=$PIECE(CODE,U,2)
- +11 SET X=" Procedure: "_CODE_" - "
- +12 IF $PIECE(Y,"^",4)
- SET X=X_$$EXTERNAL^DILFD(9000010.18,.04,"",$PIECE(Y,"^",4))
- +13 IF '$TEST
- SET X=X_$PIECE(CODE,"^",3)
- +14 SET X=X_" Quantity: "_QUAN
- End DoDot:3
- +15 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +16 SET X="^Procedure^"
- +17 IF $PIECE(Y,"^",4)
- SET X=X_$$EXTERNAL^DILFD(9000010.18,.04,"",$PIECE(Y,"^",4))
- +18 IF '$TEST
- SET X=X_$PIECE(CODE,"^",3)
- +19 SET X=X_"^"_$PIECE(CODE,"^",2)_"^"_$$SOURCE(9000010.18)_"^"_QUAN
- End DoDot:3
- +20 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +21 QUIT
- +22 ;
- HF ; -- Expand Health Factors
- +1 NEW IBDY,IBDJ,IEN,X,Y,Z
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"HF",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"HF",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=" Health Factor: "_$EXTRACT($$EXTERNAL^DILFD(9000010.23,.01,"",+Y)_L,1,25)
- +7 IF $PIECE(Y,"^",4)'=""
- SET X=X_" Severity="_$$EXTERNAL^DILFD(9000010.23,.04,"",$PIECE(Y,"^",4))
- End DoDot:3
- +8 ;
- +9 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +10 SET X=""
- +11 IF $PIECE(Y,"^",4)'=""
- SET X=$$EXTERNAL^DILFD(9000010.23,.04,"",$PIECE(Y,"^",4))
- +12 SET X=X_"^Health Factor^"_$EXTRACT($$EXTERNAL^DILFD(9000010.23,.01,"",+Y),1,25)
- +13 SET $PIECE(X,"^",5)=$$SOURCE(9000010.23)
- End DoDot:3
- +14 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- IMM ; -- Expand Immunizations
- +1 NEW IBDY,IBDJ,IEN,X,Y
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"IMM",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"IMM",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=" Immunization: "_$$EXTERNAL^DILFD(9000010.11,.01,"",+Y)
- +7 IF $PIECE(Y,"^",7)
- SET X=X_" Contraindicated!"
- End DoDot:3
- +8 ;
- +9 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +10 SET X=""
- IF $PIECE(Y,"^",7)
- SET X="Contraindicated"
- +11 SET X=X_"^Immunization^"_$$EXTERNAL^DILFD(9000010.11,.01,"",+Y)
- +12 SET $PIECE(X,"^",5)=$$SOURCE(9000010.11)
- End DoDot:3
- +13 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- PED ; -- Expand Patient Education
- +1 NEW IBDY,IBDJ,IEN,X,Y
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"PED",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"PED",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=" Education Topic: "_$EXTRACT($$EXTERNAL^DILFD(9000010.16,.01,"",+Y)_L,1,25)
- +7 IF $PIECE(Y,"^",6)'=""
- SET X=X_" Understanding="_$$EXTERNAL^DILFD(9000010.16,.06,"",$PIECE(Y,"^",6))
- End DoDot:3
- +8 ;
- +9 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +10 SET X=""
- +11 IF $PIECE(Y,"^",6)'=""
- SET X=$$EXTERNAL^DILFD(9000010.16,.06,"",$PIECE(Y,"^",6))
- +12 SET X=X_"^Education Topic^"_$EXTRACT($$EXTERNAL^DILFD(9000010.16,.01,"",+Y),1,25)
- +13 SET $PIECE(X,"^",5)=$$SOURCE(9000010.16)
- End DoDot:3
- +14 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- SK ; -- Expand Skin Tests
- +1 NEW IBDY,IBDJ,IEN,X,Y,Z
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"SK",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"SK",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=" Skin Test: "_$EXTRACT($$EXTERNAL^DILFD(9000010.12,.01,"",+Y)_L,1,25)
- +7 IF $PIECE(Y,"^",4)'=""
- SET X=X_" Result="_$$EXTERNAL^DILFD(9000010.12,.04,"",$PIECE(Y,"^",4))
- End DoDot:3
- +8 ;
- +9 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +10 SET X=$$EXTERNAL^DILFD(9000010.12,.04,"",$PIECE(Y,"^",4))
- +11 SET X=X_"^Skin Test^"_$EXTRACT($$EXTERNAL^DILFD(9000010.12,.01,"",+Y),1,25)
- +12 SET $PIECE(X,"^",5)=$$SOURCE(9000010.12)
- End DoDot:3
- +13 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- TRT ; -- Expand Treatments
- +1 NEW IBDY,IBDJ,IEN,X,Y,TRT
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"TRT",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"TRT",IEN)
- +5 SET TRT=$$EXTERNAL^DILFD(9000010.15,.01,"",+Y)
- +6 IF TRT="OTHER"
- SET TRT=$$EXTERNAL^DILFD(9000010.15,.06,"",$PIECE(Y,"^",6))
- +7 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +8 SET X=" Treatment: "_TRT
- End DoDot:3
- +9 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +10 SET X="^Treatment^"_TRT
- +11 SET $PIECE(X,"^",5)=$$SOURCE(9000010.15)
- End DoDot:3
- +12 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ;
- XAM ; -- Expand Exams
- +1 NEW IBDY,IBDJ,IEN,X,Y
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"XAM",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"XAM",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=" Exam: "_$EXTRACT($$EXTERNAL^DILFD(9000010.13,.01,"",+Y)_L,1,25)
- +7 SET X=X_" Result="_$$EXTERNAL^DILFD(9000010.13,.04,"",$PIECE(Y,"^",4))
- End DoDot:3
- +8 ;
- +9 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +10 SET X=$$EXTERNAL^DILFD(9000010.13,.04,"",$PIECE(Y,"^",4))
- +11 SET X=X_"^Exam^"_$EXTRACT($$EXTERNAL^DILFD(9000010.13,.01,"",+Y),1,25)
- +12 SET $PIECE(X,"^",5)=$$SOURCE(9000010.13)
- End DoDot:3
- +13 DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- VST ; -- Expand visit entry
- +1 NEW IBDY,IBDJ,IBDZ,IEN,X,Y
- +2 FOR IBDJ=1:1
- SET IBDY=$PIECE(ENCTRS,"^",IBDJ)
- if 'IBDY
- QUIT
- Begin DoDot:1
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXKENC",$JOB,IBDY,"VST",IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +4 DO GETY(.Y,IBDY,"VST",IEN)
- +5 IF '$GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +6 SET X=" Encounter Info: "_$$EXTERNAL^DILFD(9000010,.22,"",$PIECE(Y,"^",22))_" - "_$$FMTE^XLFDT(+Y)_" - "_$$EXTERNAL^DILFD(9000010,15003,"",$PIECE(Y(150),"^",3))_" Encounter"
- +7 DO INC(X,.CNT)
- +8 SET X=""
- +9 SET X=$$SOURCE(9000010)
- IF X'=""
- SET X=$EXTRACT(L,1,22)_"Source - "_X
- +10 IF $PIECE(Y(800),"^",1)'=""
- SET X=X_", SC := "_$SELECT($PIECE(Y(800),"^",1):"Yes",1:"No")
- +11 IF $PIECE(Y(800),"^",2)'=""
- SET X=X_", AO:="_$SELECT($PIECE(Y(800),"^",2):"Yes",1:"No")
- +12 IF $PIECE(Y(800),"^",3)'=""
- SET X=X_", IR:="_$SELECT($PIECE(Y(800),"^",3):"Yes",1:"No")
- +13 IF $PIECE(Y(800),"^",4)'=""
- SET X=X_", EC:="_$SELECT($PIECE(Y(800),"^",4):"Yes",1:"No")
- End DoDot:3
- +14 ;
- +15 IF $GET(IBDATA("UNFORMAT"))
- Begin DoDot:3
- +16 SET X=$$EXTERNAL^DILFD(9000010,15003,"",$PIECE(Y(150),"^",3))_"^Encounter^"
- +17 SET X=X_$$EXTERNAL^DILFD(9000010,.22,"",$PIECE(Y,"^",22))_"^"_$$FMTE^XLFDT(+Y)_"^"
- +18 SET X=X_$$SOURCE(9000010)
- +19 FOR IBDZ=1:1:4
- IF $PIECE(Y(800),"^",IBDZ)'=""
- SET $PIECE(X,"^",(6+IBDZ))=$PIECE(Y(800),"^",IBDZ)
- End DoDot:3
- +20 IF X'=""
- DO INC(X,.CNT)
- End DoDot:2
- End DoDot:1
- +21 QUIT
- +22 ;
- INC(X,CNT) ; -- increment results array
- +1 SET CNT=CNT+1
- +2 SET RESULT(CNT)=X
- +3 QUIT
- +4 ;
- GETY(Y,IBDY,TYPE,IEN) ; -- return y array
- +1 SET Y=$GET(^TMP("PXKENC",$JOB,IBDY,TYPE,IEN,0))
- +2 SET Y(150)=$GET(^TMP("PXKENC",$JOB,IBDY,TYPE,IEN,150))
- +3 SET Y(812)=$GET(^TMP("PXKENC",$JOB,IBDY,TYPE,IEN,812))
- +4 IF TYPE="VST"
- SET Y(800)=$GET(^TMP("PXKENC",$JOB,IBDY,TYPE,IEN,800))
- +5 QUIT
- +6 ;
- SOURCE(FILE) ; -- return source of data
- +1 NEW X
- SET X=""
- +2 IF $PIECE(Y(812),"^",3)'=""
- SET X=$$EXTERNAL^DILFD(FILE,81203,"",$PIECE(Y(812),"^",3))
- +3 IF X=""
- IF $PIECE(Y(812),"^",2)'=""
- SET X=$$EXTERNAL^DILFD(FILE,81202,"",$PIECE(Y(812),"^",2))
- +4 QUIT X
- +5 ;
- TEST GOTO TEST^IBDFRPC5
- TESTW GOTO TESTW^IBDFRPC5