- ABSPECR1 ; IHS/FCS/DRS - JWS 10:21 AM 6 Dec 1995 ; [ 09/12/2002 9:59 AM ]
- ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
- ;----------------------------------------------------------------------
- ;----------------------------------------------------------------------
- ;NCPDP Record Print-Out
- ; EN to print all formats
- ; R2^ABSPECR1(ien) to print just one format
- ;----------------------------------------------------------------------
- EN N POP,NEXTIEN
- D ^%ZIS Q:$G(POP)
- U IO
- S NEXTIEN=0
- F D Q:'+NEXTIEN
- .S NEXTIEN=$O(^ABSPF(9002313.92,NEXTIEN))
- .Q:'+NEXTIEN
- .D R2(NEXTIEN)
- D ^%ZISC
- Q
- ;---------------------------------------------------------------------
- R2(IEN) ;
- D R2^ABSPECR2(IEN)
- Q
- ; the rest of this was pretty much duplicated in ABSPECR2
- ; we enhanced what was there, too.
- ; so what follows is obsolete and can be deleted
- N FD,FIEN,GCODE,GN,MD,MIEN,NODE,O,RD,XFLAG
- Q:IEN=""
- Q:$D(^ABSPF(9002313.92,IEN,0))=0
- D R2HEADER(IEN)
- F NODE=10,20,30,40 D
- .W !
- .I NODE=10 W "Claim Header (Required) Record:",!!
- .I NODE=20 W "Claim Header (Optional) Record:",!!
- .I NODE=30 W "Claim Information (Required) Record:",!!
- .I NODE=40 W "Claim Information (Optional) Record:",!!
- .S O=0
- .F D Q:'+O
- ..S O=$O(^ABSPF(9002313.92,IEN,NODE,"B",O))
- ..Q:'+O
- ..S MIEN=$O(^ABSPF(9002313.92,IEN,NODE,"B",O,""))
- ..Q:'+MIEN
- ..S MD=$G(^ABSPF(9002313.92,IEN,NODE,MIEN,0))
- ..S FIEN=$P(MD,U,2)
- ..Q:'+FIEN
- ..S FD=$G(^ABSPF(9002313.91,FIEN,0))
- ..S:$P(MD,U,3)="X" XFLAG(NODE,MIEN)=FIEN
- ..W $J(O,3)," ",$J($P(FD,U,1),3)," ",$P(MD,U,3)," ",$P(FD,U,3),!
- H 1
- W @IOF
- D:$D(XFLAG)
- .D R2HEADER(IEN)
- .F NODE=10,20,30,40 D
- ..Q:'$D(XFLAG(NODE))
- ..W !
- ..S MIEN=""
- ..F D Q:'+MIEN
- ...S MIEN=$O(XFLAG(NODE,MIEN))
- ...Q:'+MIEN
- ...S FIEN=$G(XFLAG(NODE,MIEN))
- ...Q:FIEN=""
- ...S RD=$G(^ABSPF(9002313.91,FIEN,0))
- ...Q:RD=""
- ...W !,$J($P(RD,U,1),3),?10,$P(RD,U,3),!
- ...S GN=0
- ...F D Q:'+GN
- ....S GN=$O(^ABSPF(9002313.92,IEN,NODE,MIEN,1,GN))
- ....Q:'+GN
- ....S GCODE=$G(^ABSPF(9002313.92,IEN,NODE,MIEN,1,GN,0))
- ....W ?10,"X",GN,": ",GCODE,!
- .H 1
- .W @IOF
- Q
- ;----------------------------------------------------------------------
- W "NCPDP Record Definition"
- W $$RJBF^ABSPECFM($P($G(^ABSPF(9002313.92,IEN,0)),U,1),IOM-23),!
- W $TR($J("",IOM)," ","-"),!
- Q
- ABSPECR1 ; IHS/FCS/DRS - JWS 10:21 AM 6 Dec 1995 ; [ 09/12/2002 9:59 AM ]
- +1 ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
- +2 ;----------------------------------------------------------------------
- +3 ;----------------------------------------------------------------------
- +4 ;NCPDP Record Print-Out
- +5 ; EN to print all formats
- +6 ; R2^ABSPECR1(ien) to print just one format
- +7 ;----------------------------------------------------------------------
- EN NEW POP,NEXTIEN
- +1 DO ^%ZIS
- IF $GET(POP)
- QUIT
- +2 USE IO
- +3 SET NEXTIEN=0
- +4 FOR
- Begin DoDot:1
- +5 SET NEXTIEN=$ORDER(^ABSPF(9002313.92,NEXTIEN))
- +6 IF '+NEXTIEN
- QUIT
- +7 DO R2(NEXTIEN)
- End DoDot:1
- IF '+NEXTIEN
- QUIT
- +8 DO ^%ZISC
- +9 QUIT
- +10 ;---------------------------------------------------------------------
- R2(IEN) ;
- +1 DO R2^ABSPECR2(IEN)
- +2 QUIT
- +3 ; the rest of this was pretty much duplicated in ABSPECR2
- +4 ; we enhanced what was there, too.
- +5 ; so what follows is obsolete and can be deleted
- +6 NEW FD,FIEN,GCODE,GN,MD,MIEN,NODE,O,RD,XFLAG
- +7 IF IEN=""
- QUIT
- +8 IF $DATA(^ABSPF(9002313.92,IEN,0))=0
- QUIT
- +9 DO R2HEADER(IEN)
- +10 FOR NODE=10,20,30,40
- Begin DoDot:1
- +11 WRITE !
- +12 IF NODE=10
- WRITE "Claim Header (Required) Record:",!!
- +13 IF NODE=20
- WRITE "Claim Header (Optional) Record:",!!
- +14 IF NODE=30
- WRITE "Claim Information (Required) Record:",!!
- +15 IF NODE=40
- WRITE "Claim Information (Optional) Record:",!!
- +16 SET O=0
- +17 FOR
- Begin DoDot:2
- +18 SET O=$ORDER(^ABSPF(9002313.92,IEN,NODE,"B",O))
- +19 IF '+O
- QUIT
- +20 SET MIEN=$ORDER(^ABSPF(9002313.92,IEN,NODE,"B",O,""))
- +21 IF '+MIEN
- QUIT
- +22 SET MD=$GET(^ABSPF(9002313.92,IEN,NODE,MIEN,0))
- +23 SET FIEN=$PIECE(MD,U,2)
- +24 IF '+FIEN
- QUIT
- +25 SET FD=$GET(^ABSPF(9002313.91,FIEN,0))
- +26 IF $PIECE(MD,U,3)="X"
- SET XFLAG(NODE,MIEN)=FIEN
- +27 WRITE $JUSTIFY(O,3)," ",$JUSTIFY($PIECE(FD,U,1),3)," ",$PIECE(MD,U,3)," ",$PIECE(FD,U,3),!
- End DoDot:2
- IF '+O
- QUIT
- End DoDot:1
- +28 HANG 1
- +29 WRITE @IOF
- +30 IF $DATA(XFLAG)
- Begin DoDot:1
- +31 DO R2HEADER(IEN)
- +32 FOR NODE=10,20,30,40
- Begin DoDot:2
- +33 IF '$DATA(XFLAG(NODE))
- QUIT
- +34 WRITE !
- +35 SET MIEN=""
- +36 FOR
- Begin DoDot:3
- +37 SET MIEN=$ORDER(XFLAG(NODE,MIEN))
- +38 IF '+MIEN
- QUIT
- +39 SET FIEN=$GET(XFLAG(NODE,MIEN))
- +40 IF FIEN=""
- QUIT
- +41 SET RD=$GET(^ABSPF(9002313.91,FIEN,0))
- +42 IF RD=""
- QUIT
- +43 WRITE !,$JUSTIFY($PIECE(RD,U,1),3),?10,$PIECE(RD,U,3),!
- +44 SET GN=0
- +45 FOR
- Begin DoDot:4
- +46 SET GN=$ORDER(^ABSPF(9002313.92,IEN,NODE,MIEN,1,GN))
- +47 IF '+GN
- QUIT
- +48 SET GCODE=$GET(^ABSPF(9002313.92,IEN,NODE,MIEN,1,GN,0))
- +49 WRITE ?10,"X",GN,": ",GCODE,!
- End DoDot:4
- IF '+GN
- QUIT
- End DoDot:3
- IF '+MIEN
- QUIT
- End DoDot:2
- +50 HANG 1
- +51 WRITE @IOF
- End DoDot:1
- +52 QUIT
- +53 ;----------------------------------------------------------------------
- +1 WRITE "NCPDP Record Definition"
- +2 WRITE $$RJBF^ABSPECFM($PIECE($GET(^ABSPF(9002313.92,IEN,0)),U,1),IOM-23),!
- +3 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","-"),!
- +4 QUIT
