ABMDE9C ; IHS/ASDST/DMJ - Edit Page 9 - UB-82 CODES ;
;;2.6;IHS 3P BILLING SYSTEM;**11,14**;NOV 12, 2009;Build 238
;
; IHS/SD/SDR - v2.5 p8 - IM13796 - <UNDEF>LOOP^ABMDE9C
;IHS/SD/SDR - 2.6*14 - HEAT163734 - corrected misspelling
;
DISP ;EP - Entry Point for Occurance Codes
K ABMZ S ABMZ("TITL")="OCCURRENCE CODES",ABMZ("PG")="9A"
I $D(ABMP("DDL")),$Y>(IOSL-9) D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT I 1
E D SUM^ABMDE1
;D HD ;abm*2.6*11 HEAT87226
;
OCCR ; Occurance codes
;S ABMZ("SUB")=51,ABMZ("DR")=";W !;.02",ABMZ("ITEM")="Occurance Code",ABMZ("DIC")="^ABMDCODE(",ABMZ("X")="DINUM",ABMZ("MAX")=5 ;abm*2.6*14 HEAT163734
S ABMZ("SUB")=51,ABMZ("DR")=";W !;.02",ABMZ("ITEM")="Occurrence Code",ABMZ("DIC")="^ABMDCODE(",ABMZ("X")="DINUM",ABMZ("MAX")=5 ;abm*2.6*14 HEAT163734
;G LOOP ;abm*2.6*11 HEAT87226
D HD G LOOP ;abm*2.6*11 HEAT87226
HD W !?6,"OCCR"
W !?6,"CODE",?14," OCCURRENCE DESCRIPTION",?68,"DATE"
W !?6,"====",?14,"==================================================",?66,"========"
Q
LOOP ;
S (ABMZ("LNUM"),ABMZ("NUM"),ABMZ(1),ABM)=0 F ABM("I")=1:1 S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),51,ABM)) Q:'ABM!$D(DIRUT) S ABM("X")=ABM,ABMZ("NUM")=ABM("I") D OCCR1
I +$O(ABME(0)) S ABME("CONT")="" D ^ABMDERR K ABME("CONT")
Q
OCCR1 ;
;I $D(DIROUT)!$D(DUOUT)!$D(DTOUT)!$D(DIRUT) G XIT ;abm*2.6*11 HEAT87226
S ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),51,ABM("X"),0),ABM("X")=$P(^(0),U)
;S ABMZ(ABM("I"))=$E(($P(^ABMDCODE(ABM("X"),0),U)+100),2,3)_U_ABM_U_$P(ABM("X0"),U,2) ;abm*2.6*11
S ABMZ(ABM("I"))=$P(^ABMDCODE(ABM("X"),0),U)_U_ABM_U_$P(ABM("X0"),U,2) ;abm*2.6*11
;I $Y>(IOSL-5) D PAUSE^ABMDE1 Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) D HD ;abm*2.6*11 HEAT87226
I $Y>(IOSL-5) D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) XIT D HD ;abm*2.6*11 HEAT87226
W !,"[",ABM("I"),"]",?7,$P(ABMZ(ABM("I")),U),?14,$P(^ABMDCODE(ABM("X"),0),U,3),?66 S ABM("DT")=$P(ABM("X0"),U,2) D DT W ABM("DT")
Q
;
DISP2 ;EP - Entry Point for Occurance Span Codes
K ABMZ S ABMZ("TITL")="OCCURRENCE SPAN CODES",ABMZ("PG")="9B"
I $D(ABMP("DDL")),$Y>(IOSL-9) D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT I 1
E D SUM^ABMDE1
;
SPAN ; Occurrence Span codes
S ABMZ("SUB")=57,ABMZ("DR")=";W !;.02;W !;.03",ABMZ("ITEM")="Occurrence Span",ABMZ("DIC")="^ABMDCODE(",ABMZ("X")="X",ABMZ("MAX")=2
D HD2 G LOOP2
HD2 W !?6,"SPAN"
W !?6,"CODE",?14," OCCURRENCE SPAN DESCRIPTION",?58,"FROM",?69,"TO"
W !?6,"====",?14,"========================================",?56,"========",?66,"========"
Q
LOOP2 S (ABMZ("LNUM"),ABMZ("NUM"),ABMZ(1))=0,ABM=0 F ABM("I")=1:1 S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),57,ABM)) Q:'ABM S ABM("X")=ABM,ABMZ("NUM")=ABM("I") D SPAN1
I +$O(ABME(0)) S ABME("CONT")="" D ^ABMDERR K ABME("CONT")
Q
;
SPAN1 S ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),57,ABM("X"),0),ABM("X")=$P(^(0),U)
;S ABMZ(ABM("I"))=$E((100+$P(^ABMDCODE(ABM("X"),0),U)),2,3)_U_ABM_U_$P(ABM("X0"),U,2) ;abm*2.6*11
S ABMZ(ABM("I"))=$P(^ABMDCODE(ABM("X"),0),U)_U_ABM_U_$P(ABM("X0"),U,2) ;abm*2.6*11
I $Y>(IOSL-8) D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT D HD2
W !,"[",ABM("I"),"]",?7,$P(ABMZ(ABM("I")),U),?14,$P(^ABMDCODE(ABM("X"),0),U,3),?56 S ABM("DT")=$P(ABM("X0"),U,2) D DT W ABM("DT") S ABM("DT")=$P(ABM("X0"),U,3) D DT W ?66,ABM("DT")
Q
;
XIT K ABM,ABMZ
Q
;
DT ;date conversion
I ABM("DT")]"" S ABM("DT")=$$HDT^ABMDUTL(ABM("DT"))
Q
ABMDE9C ; IHS/ASDST/DMJ - Edit Page 9 - UB-82 CODES ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**11,14**;NOV 12, 2009;Build 238
+2 ;
+3 ; IHS/SD/SDR - v2.5 p8 - IM13796 - <UNDEF>LOOP^ABMDE9C
+4 ;IHS/SD/SDR - 2.6*14 - HEAT163734 - corrected misspelling
+5 ;
DISP ;EP - Entry Point for Occurance Codes
+1 KILL ABMZ
SET ABMZ("TITL")="OCCURRENCE CODES"
SET ABMZ("PG")="9A"
+2 IF $DATA(ABMP("DDL"))
IF $Y>(IOSL-9)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
IF 1
+3 IF '$TEST
DO SUM^ABMDE1
+4 ;D HD ;abm*2.6*11 HEAT87226
+5 ;
OCCR ; Occurance codes
+1 ;S ABMZ("SUB")=51,ABMZ("DR")=";W !;.02",ABMZ("ITEM")="Occurance Code",ABMZ("DIC")="^ABMDCODE(",ABMZ("X")="DINUM",ABMZ("MAX")=5 ;abm*2.6*14 HEAT163734
+2 ;abm*2.6*14 HEAT163734
SET ABMZ("SUB")=51
SET ABMZ("DR")=";W !;.02"
SET ABMZ("ITEM")="Occurrence Code"
SET ABMZ("DIC")="^ABMDCODE("
SET ABMZ("X")="DINUM"
SET ABMZ("MAX")=5
+3 ;G LOOP ;abm*2.6*11 HEAT87226
+4 ;abm*2.6*11 HEAT87226
DO HD
GOTO LOOP
HD WRITE !?6,"OCCR"
+1 WRITE !?6,"CODE",?14," OCCURRENCE DESCRIPTION",?68,"DATE"
+2 WRITE !?6,"====",?14,"==================================================",?66,"========"
+3 QUIT
LOOP ;
+1 SET (ABMZ("LNUM"),ABMZ("NUM"),ABMZ(1),ABM)=0
FOR ABM("I")=1:1
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),51,ABM))
IF 'ABM!$DATA(DIRUT)
QUIT
SET ABM("X")=ABM
SET ABMZ("NUM")=ABM("I")
DO OCCR1
+2 IF +$ORDER(ABME(0))
SET ABME("CONT")=""
DO ^ABMDERR
KILL ABME("CONT")
+3 QUIT
OCCR1 ;
+1 ;I $D(DIROUT)!$D(DUOUT)!$D(DTOUT)!$D(DIRUT) G XIT ;abm*2.6*11 HEAT87226
+2 SET ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),51,ABM("X"),0)
SET ABM("X")=$PIECE(^(0),U)
+3 ;S ABMZ(ABM("I"))=$E(($P(^ABMDCODE(ABM("X"),0),U)+100),2,3)_U_ABM_U_$P(ABM("X0"),U,2) ;abm*2.6*11
+4 ;abm*2.6*11
SET ABMZ(ABM("I"))=$PIECE(^ABMDCODE(ABM("X"),0),U)_U_ABM_U_$PIECE(ABM("X0"),U,2)
+5 ;I $Y>(IOSL-5) D PAUSE^ABMDE1 Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) D HD ;abm*2.6*11 HEAT87226
+6 ;abm*2.6*11 HEAT87226
IF $Y>(IOSL-5)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)
GOTO XIT
DO HD
+7 WRITE !,"[",ABM("I"),"]",?7,$PIECE(ABMZ(ABM("I")),U),?14,$PIECE(^ABMDCODE(ABM("X"),0),U,3),?66
SET ABM("DT")=$PIECE(ABM("X0"),U,2)
DO DT
WRITE ABM("DT")
+8 QUIT
+9 ;
DISP2 ;EP - Entry Point for Occurance Span Codes
+1 KILL ABMZ
SET ABMZ("TITL")="OCCURRENCE SPAN CODES"
SET ABMZ("PG")="9B"
+2 IF $DATA(ABMP("DDL"))
IF $Y>(IOSL-9)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
IF 1
+3 IF '$TEST
DO SUM^ABMDE1
+4 ;
SPAN ; Occurrence Span codes
+1 SET ABMZ("SUB")=57
SET ABMZ("DR")=";W !;.02;W !;.03"
SET ABMZ("ITEM")="Occurrence Span"
SET ABMZ("DIC")="^ABMDCODE("
SET ABMZ("X")="X"
SET ABMZ("MAX")=2
+2 DO HD2
GOTO LOOP2
HD2 WRITE !?6,"SPAN"
+1 WRITE !?6,"CODE",?14," OCCURRENCE SPAN DESCRIPTION",?58,"FROM",?69,"TO"
+2 WRITE !?6,"====",?14,"========================================",?56,"========",?66,"========"
+3 QUIT
LOOP2 SET (ABMZ("LNUM"),ABMZ("NUM"),ABMZ(1))=0
SET ABM=0
FOR ABM("I")=1:1
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),57,ABM))
IF 'ABM
QUIT
SET ABM("X")=ABM
SET ABMZ("NUM")=ABM("I")
DO SPAN1
+1 IF +$ORDER(ABME(0))
SET ABME("CONT")=""
DO ^ABMDERR
KILL ABME("CONT")
+2 QUIT
+3 ;
SPAN1 SET ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),57,ABM("X"),0)
SET ABM("X")=$PIECE(^(0),U)
+1 ;S ABMZ(ABM("I"))=$E((100+$P(^ABMDCODE(ABM("X"),0),U)),2,3)_U_ABM_U_$P(ABM("X0"),U,2) ;abm*2.6*11
+2 ;abm*2.6*11
SET ABMZ(ABM("I"))=$PIECE(^ABMDCODE(ABM("X"),0),U)_U_ABM_U_$PIECE(ABM("X0"),U,2)
+3 IF $Y>(IOSL-8)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
DO HD2
+4 WRITE !,"[",ABM("I"),"]",?7,$PIECE(ABMZ(ABM("I")),U),?14,$PIECE(^ABMDCODE(ABM("X"),0),U,3),?56
SET ABM("DT")=$PIECE(ABM("X0"),U,2)
DO DT
WRITE ABM("DT")
SET ABM("DT")=$PIECE(ABM("X0"),U,3)
DO DT
WRITE ?66,ABM("DT")
+5 QUIT
+6 ;
XIT KILL ABM,ABMZ
+1 QUIT
+2 ;
DT ;date conversion
+1 IF ABM("DT")]""
SET ABM("DT")=$$HDT^ABMDUTL(ABM("DT"))
+2 QUIT
