Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBGPOV2

PXBGPOV2.m

Go to the documentation of this file. 
  1. PXBGPOV2 ;ISL/JVS - DOUBLE ?? GATHERING OF DIAGNOSES ;27 Mar 2013  6:12 PM
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,5,11,136,149,124,203,199**;Aug 12, 1996;Build 51
  1.  ;
  1.  W !,"THIS IS NOT AN ENTRY POINT" Q
  1. DOUBLE(FROM) ;--Entry point
  1.  ;  WHAT   = The same WHAT as sent in from the API
  1.  ;  FROM   = Exactly which prompt is asking for the list
  1.  ;  SCREEN = Same as the DIC("S") screen used by FileMan
  1.  ;  START  = The starting point as to what to look up
  1.  ;
  1.  N BACK,CODE,FIELD,FILE,FIRST,HEADING,NAME,NUM,PXACS,PXACSREC,PXDXDATE
  1.  N SCREEN,START,SUB,SUB2,TEMP,TITLE,VSTIEN
  1.  S VSTIEN=$S($D(PXBVST)=1:PXBVST,$D(VISIT)=1:VISIT,1:"")
  1.  S PXDXDATE=$$CSDATE^PXDXUTL(VSTIEN)
  1.  S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
  1.  I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
  1.  S BACK="",NUM=0,SCREEN=""
  1.  D LOC
  1.  ; ICD9/ICD10 must be filtered out depending on PXDXDATE, so SCREEN must be defined
  1.  S SCREEN="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),""^"",10)"
  1.  ;
  1.  S START=$S($P(PXACSREC,"^",1)="ICD":"001.0 ",1:"A")  ; start with A codes if ICD10
  1. START ;--RECYCLE POINT
  1.  S TITLE="ALL DIAGNOSES ("_PXACS_" CODES)"
  1.  D SETUP
  1.  D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","BA",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)")
  1.  D LOC,HEAD
  1.  D SETSECND   ; SET UP DESCRIPTIONS TO GET AROUND FACT THAT THIS IS NOW A MULTIPLE FIELD IN FILE 80
  1.  D SUB
  1.  ;
  1. PROMPT ;---WRITE PROMPT HERE
  1.  D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
  1.  W !!,"Enter '^' to quit,  '-' for previous page."
  1.  S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
  1.  S DIR("?")="Enter ITEM 'No' to select , '^' to quit,  '-' for previous page."
  1.  S DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X"
  1.  D ^DIR
  1.  I X="-" S BACK="B" D BACK G START
  1.  I X="" S BACK="" D FORWARD G START
  1.  I $G(DIRUT) K DIRUT S VAL="^P" G EXIT
  1.  ;
  1. FINISH ;--FINISH SETTING A VARIABLE TO SELECTED ITEM
  1.  S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,FIRST))_"--"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,SECOND))
  1. EXIT ;--EXIT
  1.  K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
  1.  Q VAL
  1.  ;
  1. DOUBLE1(FROM) ;--Entry point
  1. NEW ;
  1.  N CNT,CODE,CYCLE,FIELD,FILE,FIRST,HEADING,HLP,INDEX,NAME,OK,PXACS
  1.  N PXACSREC,PXDXDATE,SCREEN,START,SUB,SUB2,TITLE,TOTAL,VSTIEN
  1.  S VSTIEN=$S($D(PXBVST)=1:PXBVST,$D(VISIT)=1:VISIT,1:"")
  1.  S PXDXDATE=$$CSDATE^PXDXUTL(VSTIEN)
  1.  S PXACSREC=$$ACTDT^PXDXUTL(PXDXDATE),PXACS=$P(PXACSREC,U,3)
  1.  I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
  1.  S BACK="",INDEX="BA"
  1.  S START=DATA,SUB=0,SUB2=0
  1.  S DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,PXDXDATE,$$IE^ICDEX(Y)),""^"",10)"
  1.  ;
  1. START1 ;--RECYCLE POINT
  1.  W !
  1.  S TITLE="- - S E L E C T E D  D I A G N O S E S ("_PXACS_" CODES) - -"
  1.  S FILE=80,(FIELD,FIRST)=.01,SECOND="DxDesc",EDATA=DATA
  1.  I DATA?1N S START=DATA*100 S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
  1.  I DATA?2N S START=DATA*10 S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
  1.  I DATA?3.NP S (START)=DATA-(.99) S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
  1.  I DATA?1A.ANP S START=$O(^ICD9("BA",START_" ",-1)) S INDEX="BA"
  1.  I DATA?2AP S HLP=1
  1.  I DATA?3.AP S START=$O(^ICD9("D",DATA),-1),INDEX="D"
  1.  I DATA?1A!(DATA?1.2N) D WAIT^DICD
  1.  ;
  1.  D LIST^DIC(FILE,"",FIELD,BACK,"",.START,DATA,INDEX,DIC("S"),"","^TMP(""PXBTOTAL"",$J)","^TMP(""PXBTOTAL"",$J)")
  1.  D SETSECND
  1.  ;
  1. FILTER ;--FILTER OUT DUPLICATES
  1.  N I,DXINF,DXINFARR S I=0 F  S I=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",I)) Q:I=""  D
  1.  .S DXINFARR=$$ICDDESC^ICDXCODE("DIAG",^TMP("PXBTOTAL",$J,"DILIST","ID",I,.01),PXDXDATE,.DXINFARR)
  1.  .S DXINF=$G(DXINFARR(1))
  1.  .I DXINF'="" S ^TMP("PXBOTAL",$J,$G(^TMP("PXBTOTAL",$J,"DILIST","ID",I,.01)),$E(DXINF,1,59)_" ",$G(^TMP("PXBTOTAL",$J,"DILIST",2,I))_" ")=""
  1.  K ^TMP("PXBTOTAL",$J)
  1.  N I,J,K,C S (I,J,K,C)="" F  S I=$O(^TMP("PXBOTAL",$J,I)) Q:I=""  D
  1.  .S C=C+1
  1.  .S J=$O(^TMP("PXBOTAL",$J,I,0))
  1.  .S K=$O(^TMP("PXBOTAL",$J,I,J,0))
  1.  .S ^TMP("PXBTOTAL",$J,"DILIST","ID",C,.01)=I
  1.  .S ^TMP("PXBTOTAL",$J,"DILIST","ID",C,"DxDesc")=J
  1.  .S ^TMP("PXBTOTAL",$J,"DILIST",2,C)=K
  1.  S ^TMP("PXBTOTAL",$J,"DILIST",0)=C
  1.  K ^TMP("PXBOTAL",$J)
  1.  ;
  1.  S TOTAL=$P($G(^TMP("PXBTOTAL",$J,"DILIST",0)),"^",1)
  1.  ;
  1.  ;--DISPLAY IF NO MATCH FOUND
  1.  I TOTAL<1 D
  1.  .W IOEDEOP
  1.  .I '$G(HLP) W ! D HELP^PXBUTL0("CPTM")
  1.  .I $G(HLP) S RESULTS="USE AT LEAST THE 3 CHARACTERS" W !,IOCUU,?(IOM-$L(RESULTS))\2,RESULTS
  1.  .S ERROR=1,CYCL=1
  1.  I TOTAL<1 Q TOTAL
  1.  ;
  1.  ;----DISPLAY LIST TO THE SCREEN
  1.  S HEADING="W !,""ITEM"",?6,""CODE"",?16,""DESCRIPTION    "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"
  1. LIST ;-DISPLAY LIST TO THE SCREEN
  1.  I TOTAL=1 S X=1 G VAL
  1.  D LOC,HEAD  ; W !
  1.  ;X HEADING
  1.  S SUB=SUB-1
  1.  S NUM=0 F  S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11  Q:SUB'>0  S SUB2=SUB2+1 D
  1.  .S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
  1.  .S NAME=$E($G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"DxDesc")),1,62)
  1.  .W !,SUB,?6,CODE,?16,NAME
  1.  ;
  1.  ;----If There is only one selection go to proper prompting
  1.  I TOTAL=1 G PRMPT2
  1.  ;
  1. PRMPT ;---WRITE PROMPT HERE
  1.  D WIN17^PXBCC(PXBCNT)
  1.  D LOC^PXBCC(15,1)
  1.  W !
  1.  I SUB>0 W !,"Enter '^' to quit"
  1.  E  I TOTAL>10 W !,"               END OF LIST"
  1.  I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
  1.  E  S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
  1.  S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
  1.  S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
  1.  D ^DIR
  1.  I X="",SUB>0 G LIST
  1.  I X="",SUB'>0 S X="^"
  1. VAL ;-----Set the VAL equal to the value
  1.  S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
  1. EXITNEW ;--EXIT
  1.  K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
  1.  K TANA,TOTAL
  1.  Q VAL
  1.  Q
  1.  ;
  1.  ;---SUBROUTINES
  1. BACK ;
  1.  S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
  1.  S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
  1.  Q
  1. FORWARD ;
  1.  S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
  1.  S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
  1.  Q
  1. LOC ;--LOCATE CURSOR
  1.  D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
  1.  W IOEDEOP ;--CLEAR THE PAGE
  1.  Q
  1.  W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
  1.  Q
  1. SUB ;--DISPLAY LIST TO THE SCREEN
  1.  I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!,"     E N D  O F  L I S T" Q
  1.  X HEADING
  1.  S SUB=0,CNT=0 F  S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0  S CNT=CNT+1 D
  1.  .S CODE=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,FIRST))
  1.  .S NAME=$E($G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND)),1,62)
  1.  .W !,SUB,?6,CODE,?16,NAME
  1.  Q
  1. SETUP ;-SETUP VARIABLES
  1.  S FILE=80,FIRST=.01,SECOND="DxDesc"
  1.  S FIELD=FIRST
  1.  S HEADING="W !,""ITEM"",?6,""CODE"",?16,""DESCRIPTION"""
  1.  Q
  1. SETSECND ;
  1.  N NAMEARR
  1.  S SUB=0 F  S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0  D
  1.  . S CODE=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,FIRST))
  1.  . S NAMEARR=$$ICDDESC^ICDXCODE("DIAG",CODE,PXDXDATE,.NAMEARR)
  1.  . S ^TMP("PXBTANA",$J,"DILIST","ID",SUB,SECOND)=$G(NAMEARR(1))
  1.  Q
  1.  ;
  1. PRMPT2 ;-----Yes and No prompt if only choice
  1.  D WIN17^PXBCC(PXBCNT)
  1.  D LOC^PXBCC(15,1)
  1.  S DIR("A")="Is this the correct entry "
  1.  S DIR("B")="YES"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  I Y=0 S X="^"
  1.  I Y=1 S X=1
  1.  G VAL